Start9/registry
2
0
Fork 0
mirror of https://github.com/Start9Labs/registry.git synced 2026-03-26 10:21:51 +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
import Startlude hiding ( Handler )
import Startlude hiding ( Handler
, get
)
import Control.Monad.Logger ( Loc
, LogSource
@@ -43,9 +45,8 @@ import qualified Data.Text as T
import Language.Haskell.TH ( Loc(..) )
import Lib.PkgRepository
import Lib.Types.AppIndex
import Model ( Admin
, EntityField(AdminName, AdminPassHash)
, Unique(UniqueAdmin)
import Model ( Admin(..)
, Key(AdminKey)
)
import Settings
import System.Console.ANSI.Codes ( Color(..)
@@ -218,8 +219,10 @@ instance YesodAuth RegistryCtx where
pool <- getsYesod appConnPool
let checkCreds k s = flip runSqlPool pool $ do
let passHash = hashWith SHA256 . encodeUtf8 . ("start9_admin:" <>) $ decodeUtf8 s
ls <- selectList [AdminName ==. decodeUtf8 k, AdminPassHash ==. passHash] []
pure . not . null $ ls
get (AdminKey $ decodeUtf8 k) <&> \case
Nothing -> False
Just Admin { adminPassHash } -> adminPassHash == passHash
defaultMaybeBasicAuthId checkCreds defaultAuthSettings
loginDest _ = PackageListR
logoutDest _ = PackageListR
@@ -227,7 +230,7 @@ instance YesodAuth RegistryCtx where
instance YesodAuthPersist RegistryCtx where
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
, sinkFile
)
import Control.Exception ( ErrorCall(ErrorCall) )
import Control.Monad.Reader.Has ( ask )
import Control.Monad.Trans.Maybe ( MaybeT(..) )
import Data.Aeson ( (.:)
@@ -20,6 +21,7 @@ import Data.Aeson ( (.:)
)
import Data.String.Interpolate.IsString
( i )
import Database.Persist ( insert_ )
import Database.Persist.Postgresql ( runSqlPoolNoTransaction )
import Database.Queries ( upsertPackageVersion )
import Foundation
@@ -31,7 +33,9 @@ import Lib.Types.AppIndex ( PackageManifest(..)
, PkgId(unPkgId)
)
import Lib.Types.Emver ( Version(..) )
import Model ( Key(PkgRecordKey, VersionRecordKey) )
import Model ( Key(AdminKey, PkgRecordKey, VersionRecordKey)
, Upload(..)
)
import Network.HTTP.Types ( status404
, status500
)
@@ -42,14 +46,17 @@ import Startlude ( ($)
, Bool(..)
, Eq
, Maybe(..)
, Monad((>>=))
, Show
, SomeException(..)
, asum
, getCurrentTime
, hush
, isNothing
, liftIO
, replicate
, show
, throwIO
, toS
, when
)
@@ -75,6 +82,7 @@ import Yesod ( ToJSON(..)
, requireCheckJsonBody
, runDB
)
import Yesod.Auth ( YesodAuth(maybeAuthId) )
postPkgUploadR :: Handler ()
postPkgUploadR = do
@@ -94,6 +102,14 @@ postPkgUploadR = do
removePathForcibly targetPath
createDirectoryIfMissing True 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)

7
src/Model.hs
View File

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