From 11e361fc5b28f4017877a17164371933d0cfa9f7 Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Wed, 25 May 2022 15:54:11 -0600 Subject: [PATCH] log uploads --- src/Foundation.hs | 17 ++++++++++------- src/Handler/Admin.hs | 18 +++++++++++++++++- src/Model.hs | 7 +------ 3 files changed, 28 insertions(+), 14 deletions(-) diff --git a/src/Foundation.hs b/src/Foundation.hs index 6af5531..cabbd73 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -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 diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index c324945..1d8030c 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -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) diff --git a/src/Model.hs b/src/Model.hs index 291d1bb..a9602d3 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -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