Start9/registry
2
0
Fork 0
mirror of https://github.com/Start9Labs/registry.git synced 2026-04-04 13:49:43 +00:00
Code Issues Packages Projects Releases Wiki Activity

log uploads

Browse Source
This commit is contained in:
Keagan McClelland
2022-05-25 15:54:11 -06:00
parent 2cf1e17057
commit 090a14506e
3 changed files with 28 additions and 14 deletions
Download Patch File Download Diff File Expand all files Collapse all files

17
src/Foundation.hs
View File

@@ -13,7 +13,9 @@
module Foundation where module Foundation where
import Startlude hiding ( Handler ) import Startlude hiding ( Handler
, get
)
import Control.Monad.Logger ( Loc import Control.Monad.Logger ( Loc
, LogSource , LogSource
@@ -43,9 +45,8 @@ import qualified Data.Text as T
import Language.Haskell.TH ( Loc(..) ) import Language.Haskell.TH ( Loc(..) )
import Lib.PkgRepository import Lib.PkgRepository
import Lib.Types.AppIndex import Lib.Types.AppIndex
import Model ( Admin import Model ( Admin(..)
, EntityField(AdminName, AdminPassHash) , Key(AdminKey)
, Unique(UniqueAdmin)
) )
import Settings import Settings
import System.Console.ANSI.Codes ( Color(..) import System.Console.ANSI.Codes ( Color(..)
@@ -218,8 +219,10 @@ instance YesodAuth RegistryCtx where
pool <- getsYesod appConnPool pool <- getsYesod appConnPool
let checkCreds k s = flip runSqlPool pool $ do let checkCreds k s = flip runSqlPool pool $ do
let passHash = hashWith SHA256 . encodeUtf8 . ("start9_admin:" <>) $ decodeUtf8 s let passHash = hashWith SHA256 . encodeUtf8 . ("start9_admin:" <>) $ decodeUtf8 s
ls <- selectList [AdminName ==. decodeUtf8 k, AdminPassHash ==. passHash] [] get (AdminKey $ decodeUtf8 k) <&> \case
pure . not . null $ ls Nothing -> False
Just Admin { adminPassHash } -> adminPassHash == passHash
defaultMaybeBasicAuthId checkCreds defaultAuthSettings defaultMaybeBasicAuthId checkCreds defaultAuthSettings
loginDest _ = PackageListR loginDest _ = PackageListR
logoutDest _ = PackageListR logoutDest _ = PackageListR
@@ -227,7 +230,7 @@ instance YesodAuth RegistryCtx where
instance YesodAuthPersist RegistryCtx where instance YesodAuthPersist RegistryCtx where
type AuthEntity RegistryCtx = Admin type AuthEntity RegistryCtx = Admin
getAuthEntity = (entityVal <<$>>) . liftHandler . runDB . getBy . UniqueAdmin getAuthEntity = liftHandler . runDB . get . AdminKey

18
src/Handler/Admin.hs
View File

@@ -8,6 +8,7 @@ import Conduit ( (.|)
, runConduit , runConduit
, sinkFile , sinkFile
) )
import Control.Exception ( ErrorCall(ErrorCall) )
import Control.Monad.Reader.Has ( ask ) import Control.Monad.Reader.Has ( ask )
import Control.Monad.Trans.Maybe ( MaybeT(..) ) import Control.Monad.Trans.Maybe ( MaybeT(..) )
import Data.Aeson ( (.:) import Data.Aeson ( (.:)
@@ -20,6 +21,7 @@ import Data.Aeson ( (.:)
) )
import Data.String.Interpolate.IsString import Data.String.Interpolate.IsString
( i ) ( i )
import Database.Persist ( insert_ )
import Database.Persist.Postgresql ( runSqlPoolNoTransaction ) import Database.Persist.Postgresql ( runSqlPoolNoTransaction )
import Database.Queries ( upsertPackageVersion ) import Database.Queries ( upsertPackageVersion )
import Foundation import Foundation
@@ -31,7 +33,9 @@ import Lib.Types.AppIndex ( PackageManifest(..)
, PkgId(unPkgId) , PkgId(unPkgId)
) )
import Lib.Types.Emver ( Version(..) ) import Lib.Types.Emver ( Version(..) )
import Model ( Key(PkgRecordKey, VersionRecordKey) ) import Model ( Key(AdminKey, PkgRecordKey, VersionRecordKey)
, Upload(..)
)
import Network.HTTP.Types ( status404 import Network.HTTP.Types ( status404
, status500 , status500
) )
@@ -42,14 +46,17 @@ import Startlude ( ($)
, Bool(..) , Bool(..)
, Eq , Eq
, Maybe(..) , Maybe(..)
, Monad((>>=))
, Show , Show
, SomeException(..) , SomeException(..)
, asum , asum
, getCurrentTime
, hush , hush
, isNothing , isNothing
, liftIO , liftIO
, replicate , replicate
, show , show
, throwIO
, toS , toS
, when , when
) )
@@ -75,6 +82,7 @@ import Yesod ( ToJSON(..)
, requireCheckJsonBody , requireCheckJsonBody
, runDB , runDB
) )
import Yesod.Auth ( YesodAuth(maybeAuthId) )
postPkgUploadR :: Handler () postPkgUploadR :: Handler ()
postPkgUploadR = do postPkgUploadR = do
@@ -94,6 +102,14 @@ postPkgUploadR = do
removePathForcibly targetPath removePathForcibly targetPath
createDirectoryIfMissing True targetPath createDirectoryIfMissing True targetPath
renameDirectory dir targetPath renameDirectory dir targetPath
maybeAuthId >>= \case
Nothing -> do
$logError
"The Impossible has happened, an unauthenticated user has managed to upload a pacakge to this registry"
throwIO $ ErrorCall "Unauthenticated user has uploaded package to registry!!!"
Just name -> do
now <- liftIO getCurrentTime
runDB $ insert_ (Upload (AdminKey name) (PkgRecordKey packageManifestId) packageManifestVersion now)
where retry m = runMaybeT . asum $ replicate 3 (MaybeT $ hush <$> try @_ @SomeException m) where retry m = runMaybeT . asum $ replicate 3 (MaybeT $ hush <$> try @_ @SomeException m)

7
src/Model.hs
View File

@@ -24,10 +24,6 @@ PkgRecord
Id PkgId sql=pkg_id Id PkgId sql=pkg_id
createdAt UTCTime createdAt UTCTime
updatedAt UTCTime Maybe updatedAt UTCTime Maybe
-- title Text
-- descShort Text
-- descLong Text
-- iconType Text
deriving Eq deriving Eq
deriving Show deriving Show
@@ -108,10 +104,9 @@ PkgDependency
deriving Show deriving Show
Admin Admin
Id Text
createdAt UTCTime createdAt UTCTime
name Text
passHash (Digest SHA256) passHash (Digest SHA256)
UniqueAdmin name
Upload Upload
uploader AdminId uploader AdminId