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

Feature/api versioning (#106)

Browse Source 
* wip

* finishes initial refactor

* prune unused code

* finished massive refactor

* remove commented deps

* fix import

* fix bug
This commit is contained in:
Keagan McClelland
2022-06-20 10:28:28 -06:00
committed by GitHub
parent bb0488f1dd
commit dbd73fae7f
44 changed files with 3115 additions and 3055 deletions
Download Patch File Download Diff File Expand all files Collapse all files

394
src/Foundation.hs
View File

@@ -1,184 +1,202 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Foundation where
import Startlude ( ($)
, (.)
, (<$>)
, (<&>)
, (<**>)
, (=<<)
, Applicative(pure)
, Bool(False)
, Eq((==))
, IO
, MVar
, Maybe(..)
, Monad(return)
, Monoid(mempty)
, Semigroup((<>))
, String
, Text
, ThreadId
, Word64
, decodeUtf8
, drop
, encodeUtf8
, flip
, fst
, isJust
, otherwise
, putMVar
, show
, when
, (||)
)
import Startlude (
Applicative (pure),
Bool (False),
Eq ((==)),
IO,
MVar,
Maybe (..),
Monad (return),
Monoid (mempty),
Semigroup ((<>)),
String,
Text,
ThreadId,
Word64,
decodeUtf8,
drop,
encodeUtf8,
flip,
fst,
isJust,
otherwise,
putMVar,
show,
when,
($),
(.),
(<$>),
(<&>),
(<**>),
(=<<),
(||),
)
import Control.Monad.Logger ( Loc
, LogSource
, LogStr
, ToLogStr(toLogStr)
, fromLogStr
)
import Database.Persist.Sql ( ConnectionPool
, LogFunc
, PersistStoreRead(get)
, SqlBackend
, SqlPersistT
, runSqlPool
)
import Lib.Registry ( S9PK )
import Yesod.Core ( AuthResult(Authorized, Unauthorized)
, LogLevel(..)
, MonadHandler(liftHandler)
, RenderMessage(..)
, RenderRoute(Route, renderRoute)
, RouteAttrs(routeAttrs)
, SessionBackend
, ToTypedContent
, Yesod
( isAuthorized
, makeLogger
, makeSessionBackend
, maximumContentLengthIO
, messageLoggerSource
, shouldLogIO
, yesodMiddleware
)
, defaultYesodMiddleware
, getYesod
, getsYesod
, mkYesodData
, parseRoutesFile
)
import Yesod.Core.Types ( HandlerData(handlerEnv)
, Logger(loggerDate)
, RunHandlerEnv(rheChild, rheSite)
, loggerPutStr
)
import qualified Yesod.Core.Unsafe as Unsafe
import Control.Monad.Logger (
Loc,
LogSource,
LogStr,
ToLogStr (toLogStr),
fromLogStr,
)
import Database.Persist.Sql (
ConnectionPool,
LogFunc,
PersistStoreRead (get),
SqlBackend,
SqlPersistT,
runSqlPool,
)
import Yesod.Core (
AuthResult (Authorized, Unauthorized),
LogLevel (..),
MonadHandler (liftHandler),
RenderMessage (..),
RenderRoute (Route, renderRoute),
RouteAttrs (routeAttrs),
SessionBackend,
ToTypedContent,
Yesod (
isAuthorized,
makeLogger,
makeSessionBackend,
maximumContentLengthIO,
messageLoggerSource,
shouldLogIO,
yesodMiddleware
),
defaultYesodMiddleware,
getYesod,
getsYesod,
mkYesodData,
parseRoutesFile,
)
import Yesod.Core.Types (
HandlerData (handlerEnv),
Logger (loggerDate),
RunHandlerEnv (rheChild, rheSite),
loggerPutStr,
)
import Yesod.Core.Unsafe qualified as Unsafe
import Control.Monad.Logger.Extras (wrapSGRCode)
import Control.Monad.Reader.Has (Has (extract, update))
import Crypto.Hash (
SHA256 (SHA256),
hashWith,
)
import Data.Set (member)
import Data.String.Interpolate.IsString (
i,
)
import Data.Text qualified as T
import Handler.Types.Api (ApiVersion (..))
import Language.Haskell.TH (Loc (..))
import Lib.PkgRepository (
EosRepo,
PkgRepo,
)
import Lib.Types.Core (PkgId, S9PK)
import Model (
Admin (..),
Key (AdminKey),
)
import Settings (AppSettings (appShouldLogAll))
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 (
DBRunner,
YesodPersist (..),
YesodPersistRunner (..),
defaultGetDBRunner,
)
import Control.Monad.Logger.Extras ( wrapSGRCode )
import Control.Monad.Reader.Has ( Has(extract, update) )
import Crypto.Hash ( SHA256(SHA256)
, hashWith
)
import Data.Set ( member )
import Data.String.Interpolate.IsString
( i )
import qualified Data.Text as T
import Language.Haskell.TH ( Loc(..) )
import Lib.PkgRepository ( EosRepo
, PkgRepo
)
import Lib.Types.AppIndex ( PkgId )
import Model ( Admin(..)
, Key(AdminKey)
)
import Settings ( AppSettings(appShouldLogAll) )
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 ( DBRunner
, YesodPersist(..)
, YesodPersistRunner(..)
, defaultGetDBRunner
)
-- | The foundation datatype for your application. This can be a good place to
-- keep settings and values requiring initialization before your application
-- starts running, such as database connections. Every handler will have
-- access to the data present here.
data RegistryCtx = RegistryCtx
{ appSettings :: AppSettings
, appLogger :: Logger
{ appSettings :: AppSettings
, appLogger :: Logger
, appWebServerThreadId :: MVar (ThreadId, ThreadId)
, appShouldRestartWeb :: MVar Bool
, appConnPool :: ConnectionPool
, appStopFsNotifyEos :: IO Bool
, appShouldRestartWeb :: MVar Bool
, appConnPool :: ConnectionPool
, appStopFsNotifyEos :: IO Bool
}
instance Has PkgRepo RegistryCtx where
extract = transitiveExtract @AppSettings
update = transitiveUpdate @AppSettings
update = transitiveUpdate @AppSettings
instance Has a r => Has a (HandlerData r r) where
extract = extract . rheSite . handlerEnv
update f r =
let ctx = update f (rheSite $ handlerEnv r)
rhe = (handlerEnv r) { rheSite = ctx, rheChild = ctx }
in r { handlerEnv = rhe }
rhe = (handlerEnv r){rheSite = ctx, rheChild = ctx}
in r{handlerEnv = rhe}
instance Has AppSettings RegistryCtx where
extract = appSettings
update f ctx = ctx { appSettings = f (appSettings ctx) }
update f ctx = ctx{appSettings = f (appSettings ctx)}
instance Has EosRepo RegistryCtx where
extract = transitiveExtract @AppSettings
update = transitiveUpdate @AppSettings
update = transitiveUpdate @AppSettings
{-# INLINE transitiveExtract #-}
transitiveExtract :: forall b a c . (Has a b, Has b c) => c -> a
transitiveExtract :: forall b a c. (Has a b, Has b c) => c -> a
transitiveExtract = extract @a . extract @b
{-# INLINE transitiveUpdate #-}
transitiveUpdate :: forall b a c . (Has a b, Has b c) => (a -> a) -> (c -> c)
transitiveUpdate :: forall b a c. (Has a b, Has b c) => (a -> a) -> (c -> c)
transitiveUpdate f = update (update @a @b f)
setWebProcessThreadId :: (ThreadId, ThreadId) -> RegistryCtx -> IO ()
setWebProcessThreadId tid@(!_, !_) a = putMVar (appWebServerThreadId a) tid
-- This is where we define all of the routes in our application. For a full
-- explanation of the syntax, please see:
-- http://www.yesodweb.com/book/routing-and-handlers
@@ -193,68 +211,73 @@ setWebProcessThreadId tid@(!_, !_) a = putMVar (appWebServerThreadId a) tid
-- type Handler = HandlerT RegistryCtx IO
mkYesodData "RegistryCtx" $(parseRoutesFile "config/routes")
-- Please see the documentation for the Yesod typeclass. There are a number
-- of settings which can be configured by overriding methods here.
instance Yesod RegistryCtx where
-- Store session data on the client in encrypted cookies,
-- default session idle timeout is 120 minutes
-- Store session data on the client in encrypted cookies,
-- default session idle timeout is 120 minutes
makeSessionBackend :: RegistryCtx -> IO (Maybe SessionBackend)
makeSessionBackend _ = pure Nothing
-- Yesod Middleware allows you to run code before and after each handler function.
-- The defaultYesodMiddleware adds the response header "Vary: Accept, Accept-Language" and performs authorization checks.
-- Some users may also want to add the defaultCsrfMiddleware, which:
-- a) Sets a cookie with a CSRF token in it.
-- b) Validates that incoming write requests include that token in either a header or POST parameter.
-- To add it, chain it together with the defaultMiddleware: yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware
-- For details, see the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package.
-- Yesod Middleware allows you to run code before and after each handler function.
-- The defaultYesodMiddleware adds the response header "Vary: Accept, Accept-Language" and performs authorization checks.
-- Some users may also want to add the defaultCsrfMiddleware, which:
-- a) Sets a cookie with a CSRF token in it.
-- b) Validates that incoming write requests include that token in either a header or POST parameter.
-- To add it, chain it together with the defaultMiddleware: yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware
-- For details, see the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package.
yesodMiddleware :: ToTypedContent res => Handler res -> Handler res
yesodMiddleware = defaultYesodMiddleware
-- What messages should be logged. The following includes all messages when
-- in development, and warnings and errors in production.
-- What messages should be logged. The following includes all messages when
-- in development, and warnings and errors in production.
shouldLogIO :: RegistryCtx -> LogSource -> LogLevel -> IO Bool
shouldLogIO app _source level =
return $ appShouldLogAll (appSettings app) || level == LevelInfo || level == LevelWarn || level == LevelError
makeLogger :: RegistryCtx -> IO Logger
makeLogger = return . appLogger
messageLoggerSource :: RegistryCtx -> Logger -> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
messageLoggerSource ctx logger = \loc src lvl str -> do
shouldLog <- shouldLogIO ctx src lvl
when shouldLog $ do
date <- loggerDate logger
let
formatted =
let formatted =
toLogStr date
<> ( toLogStr
. wrapSGRCode [SetColor Foreground Vivid (colorFor lvl)]
$ fromLogStr
( " ["
<> renderLvl lvl
<> (if T.null src then mempty else "#" <> toLogStr src)
<> "] "
<> str
)
. wrapSGRCode [SetColor Foreground Vivid (colorFor lvl)]
$ fromLogStr
( " ["
<> renderLvl lvl
<> (if T.null src then mempty else "#" <> toLogStr src)
<> "] "
<> str
)
)
<> toLogStr
(wrapSGRCode [SetColor Foreground Dull White]
[i| @ #{loc_filename loc}:#{fst $ loc_start loc}\n|]
)
( wrapSGRCode
[SetColor Foreground Dull White]
[i| @ #{loc_filename loc}:#{fst $ loc_start loc}\n|]
)
loggerPutStr logger formatted
where
renderLvl lvl = case lvl of
LevelOther t -> toLogStr t
_ -> toLogStr @String $ drop 5 $ show lvl
_ -> toLogStr @String $ drop 5 $ show lvl
colorFor = \case
LevelDebug -> Green
LevelInfo -> Blue
LevelWarn -> Yellow
LevelError -> Red
LevelDebug -> Green
LevelInfo -> Blue
LevelWarn -> Yellow
LevelError -> Red
LevelOther _ -> White
isAuthorized :: Route RegistryCtx -> Bool -> Handler AuthResult
isAuthorized route _
| "admin" `member` routeAttrs route = do
@@ -262,9 +285,11 @@ instance Yesod RegistryCtx where
pure $ if hasAuthId then Authorized else Unauthorized "This feature is for admins only"
| otherwise = pure Authorized
maximumContentLengthIO :: RegistryCtx -> Maybe (Route RegistryCtx) -> IO (Maybe Word64)
maximumContentLengthIO _ (Just PkgUploadR) = pure Nothing
maximumContentLengthIO _ _ = pure $ Just 2097152 -- the original default
maximumContentLengthIO _ _ = pure $ Just 2097152 -- the original default
-- How to run database actions.
instance YesodPersist RegistryCtx where
@@ -272,37 +297,40 @@ instance YesodPersist RegistryCtx where
runDB :: SqlPersistT Handler a -> Handler a
runDB action = runSqlPool action . appConnPool =<< getYesod
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
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
get (AdminKey $ decodeUtf8 k) <&> \case
Nothing -> False
Just Admin { adminPassHash } -> adminPassHash == passHash
Nothing -> False
Just Admin{adminPassHash} -> adminPassHash == passHash
defaultMaybeBasicAuthId checkCreds defaultAuthSettings
loginDest _ = PackageListR
logoutDest _ = PackageListR
loginDest _ = PackageIndexR V1
logoutDest _ = PackageIndexR V1
authPlugins _ = []
instance YesodAuthPersist RegistryCtx where
type AuthEntity RegistryCtx = Admin
getAuthEntity = liftHandler . runDB . get . AdminKey
unsafeHandler :: RegistryCtx -> Handler a -> IO a
unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger
-- Note: Some functionality previously present in the scaffolding has been
-- moved to documentation in the Wiki. Following are some hopefully helpful
-- links: