Start9/registry
2
0
Fork 0
mirror of https://github.com/Start9Labs/registry.git synced 2026-03-26 02:11:53 +00:00
Code Issues Packages Projects Releases Wiki Activity

implements basic authentication for admins

Browse Source
This commit is contained in:
Keagan McClelland
2022-05-20 17:09:14 -06:00
parent e5efb877d3
commit d2aee89cda
5 changed files with 105 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

46
src/Foundation.hs
View File

@@ -33,18 +33,43 @@ import qualified Yesod.Core.Unsafe as Unsafe
import Control.Monad.Logger.Extras ( wrapSGRCode )
import Control.Monad.Reader.Has ( Has(extract, update) )
import Crypto.Hash ( SHA256(SHA256)
, hashWith
)
import Data.String.Interpolate.IsString
( i )
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 Settings
import System.Console.ANSI.Codes ( Color(..)
, ColorIntensity(..)
, ConsoleLayer(Foreground)
, SGR(SetColor)
)
import Yesod ( FormMessage
, defaultFormMessage
)
import Yesod.Auth ( AuthEntity
, Creds(credsIdent)
, YesodAuth
( AuthId
, authPlugins
, getAuthId
, loginDest
, logoutDest
, maybeAuthId
)
, YesodAuthPersist(getAuthEntity)
)
import Yesod.Auth.Http.Basic ( defaultAuthSettings
, defaultMaybeBasicAuthId
)
import Yesod.Persist.Core
-- | The foundation datatype for your application. This can be a good place to
@@ -175,6 +200,27 @@ instance YesodPersistRunner RegistryCtx where
getDBRunner :: Handler (DBRunner RegistryCtx, Handler ())
getDBRunner = defaultGetDBRunner appConnPool
instance RenderMessage RegistryCtx FormMessage where
renderMessage _ _ = defaultFormMessage
instance YesodAuth RegistryCtx where
type AuthId RegistryCtx = Text
getAuthId = pure . Just . credsIdent
maybeAuthId = do
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
defaultMaybeBasicAuthId checkCreds defaultAuthSettings
loginDest _ = PackageListR
logoutDest _ = PackageListR
authPlugins _ = []
instance YesodAuthPersist RegistryCtx where
type AuthEntity RegistryCtx = Admin
getAuthEntity = (entityVal <<$>>) . liftHandler . runDB . getBy . UniqueAdmin
unsafeHandler :: RegistryCtx -> Handler a -> IO a
unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger

14
src/Model.hs
View File

@@ -11,9 +11,11 @@
module Model where
import Crypto.Hash
import Database.Persist.TH
import Lib.Types.AppIndex
import Lib.Types.Emver
import Orphans.Cryptonite ( )
import Orphans.Emver ( )
import Startlude
@@ -100,4 +102,16 @@ PkgDependency
UniquePkgDepVersion pkgId pkgVersion depId
deriving Eq
deriving Show
Admin
createdAt UTCTime
name Text
passHash (Digest SHA256)
UniqueAdmin name
Upload
uploader AdminId
pkgId PkgRecordId
pkgVersion Version
createdAt UTCTime
|]

42
src/Orphans/Cryptonite.hs Normal file
View File

@@ -0,0 +1,42 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE TypeApplications #-}
module Orphans.Cryptonite where
import Crypto.Hash ( Digest
, digestFromByteString
)
import Crypto.Hash.Algorithms ( SHA256 )
import Data.ByteArray.Encoding ( Base(Base16)
, convertFromBase
, convertToBase
)
import Data.Text ( pack )
import Database.Persist ( PersistField(..)
, PersistValue(PersistText)
, SqlType(SqlString)
)
import Database.Persist.Sql ( PersistFieldSql(..) )
import Startlude ( ($)
, (.)
, Bifunctor(bimap, first)
, ByteString
, Either(Left)
, Semigroup((<>))
, decodeUtf8
, encodeUtf8
, join
, note
, show
)
instance PersistField (Digest SHA256) where
toPersistValue = PersistText . decodeUtf8 . convertToBase Base16
fromPersistValue (PersistText t) =
join
. bimap pack (note "Invalid SHA256 Digest" . digestFromByteString)
. convertFromBase @_ @ByteString Base16
. encodeUtf8
$ t
fromPersistValue v = Left $ "Invalid PersistValue type: " <> show v
instance PersistFieldSql (Digest SHA256) where
sqlType _ = SqlString