JWT support works
This commit is contained in:
parent
edb27838cc
commit
5cba7e5827
13 changed files with 175 additions and 96 deletions
|
|
@ -20,6 +20,7 @@ data ServerConfig = ServerConfig
|
|||
-- , configMaxConnectionsPerClient :: Word
|
||||
-- , configBlockRegistration :: Bool
|
||||
, configSendmailPath :: FilePath
|
||||
, configJWTSecret :: T.Text
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
|
|
@ -37,6 +38,7 @@ instance FromJSON ServerConfig where
|
|||
-- <*> m .:? "max_connections_per_client" .!= 10
|
||||
-- <*> m .: "block_registration"
|
||||
<*> m .: "sendmail_path"
|
||||
<*> m .: "jwt_secret"
|
||||
parseJSON _ = error "Can not parse configuration"
|
||||
|
||||
data Options = Options
|
||||
|
|
|
|||
35
app/Main.hs
35
app/Main.hs
|
|
@ -10,6 +10,9 @@ module Main where
|
|||
|
||||
import Prelude as P
|
||||
|
||||
import Crypto.JWT hiding (Context, header)
|
||||
import Crypto.JOSE.JWK hiding (Context)
|
||||
|
||||
import Control.Concurrent.STM (newTQueueIO)
|
||||
import Control.Concurrent (forkIO)
|
||||
|
||||
|
|
@ -19,21 +22,22 @@ import qualified Servant.OpenApi as OA
|
|||
import Servant.Swagger.UI
|
||||
import Servant.RawM
|
||||
|
||||
import qualified Data.Aeson as A
|
||||
|
||||
import Data.Set as S (empty)
|
||||
import qualified Data.ByteString.Lazy as B
|
||||
import Data.ByteString.Char8 as B8 hiding (putStrLn)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as TE
|
||||
import Data.String
|
||||
import Data.Yaml
|
||||
import Data.Version (showVersion)
|
||||
import Data.IP
|
||||
import qualified Data.OpenApi as OA hiding (Server)
|
||||
|
||||
import Database.PostgreSQL.Simple
|
||||
import Database.PostgreSQL.Simple.Migration
|
||||
import Database.PostgreSQL.Simple.Util
|
||||
|
||||
import Network.Socket (defaultPort)
|
||||
|
||||
import Network.Wai
|
||||
import Network.Wai.Logger
|
||||
import Network.Wai.Handler.Warp
|
||||
|
|
@ -86,6 +90,7 @@ main = do
|
|||
-- max_conn_per_client
|
||||
-- block_registration
|
||||
sendmail_path
|
||||
jwt_secret
|
||||
) -> do
|
||||
conn <- connectPostgreSQL (
|
||||
"host='" <> fromString (T.unpack db_host) <> "' " <>
|
||||
|
|
@ -141,6 +146,8 @@ main = do
|
|||
, rsSoftwareVersion = T.pack (showVersion version)
|
||||
, rsSendmailPath = sendmail_path
|
||||
, rsMailQueue = mailQueue
|
||||
, rsJWTSecret =
|
||||
fromOctets . B.fromStrict $ TE.encodeUtf8 jwt_secret
|
||||
}
|
||||
expirationSpec = TimeSpec 5 0 -- five seconds
|
||||
runSettings settings (app initState)
|
||||
|
|
@ -154,7 +161,8 @@ main = do
|
|||
app :: ReadState -> Application
|
||||
-- app conn = serveWithContext userApi genAuthServerContext (users conn)
|
||||
app initState =
|
||||
serveWithContext combinedAPI (genAuthServerContext (rsConnection initState)) server
|
||||
serveWithContext combinedAPI
|
||||
(genAuthServerContext (rsJWTSecret initState) (rsConnection initState)) server
|
||||
where
|
||||
server :: Server CombinedAPI
|
||||
server = appToServer initState mateAPI thisApi :<|>
|
||||
|
|
@ -168,7 +176,6 @@ appToServer initState myApi =
|
|||
|
||||
thisApi :: ServerT MateAPI MateHandler
|
||||
thisApi =
|
||||
authGet :<|>
|
||||
authSend :<|>
|
||||
authLogout :<|>
|
||||
|
||||
|
|
@ -232,21 +239,22 @@ authProxy :: Proxy '[ AuthHandler Request (Maybe (Int, AuthMethod)) ]
|
|||
authProxy = Proxy
|
||||
|
||||
genAuthServerContext
|
||||
:: Connection
|
||||
:: JWK
|
||||
-> Connection
|
||||
-> Context '[ AuthHandler Request (Maybe (Int, AuthMethod)) ]
|
||||
genAuthServerContext conn = authHandler conn Servant.:. EmptyContext
|
||||
genAuthServerContext key conn = authHandler key conn Servant.:. EmptyContext
|
||||
|
||||
type instance AuthServerData (AuthProtect "header-auth") = Maybe (Int, AuthMethod)
|
||||
|
||||
authHandler :: Connection -> AuthHandler Request (Maybe (Int, AuthMethod))
|
||||
authHandler conn = mkAuthHandler handler
|
||||
authHandler :: JWK -> Connection -> AuthHandler Request (Maybe (Int, AuthMethod))
|
||||
authHandler key conn = mkAuthHandler handler
|
||||
where
|
||||
handler :: Request -> Handler (Maybe (Int, AuthMethod))
|
||||
handler req = do
|
||||
let headers = requestHeaders req
|
||||
case lookup "Authentication" headers of
|
||||
Just hh ->
|
||||
validateToken hh conn
|
||||
case lookup "Authorization" headers of
|
||||
Just hh -> do
|
||||
validateToken (B8.drop 7 hh) key conn
|
||||
_ ->
|
||||
return Nothing
|
||||
|
||||
|
|
@ -255,3 +263,6 @@ instance OA.HasOpenApi sub => OA.HasOpenApi (AuthProtect "header-auth" :> sub) w
|
|||
|
||||
instance OA.HasOpenApi (RawM' Application) where
|
||||
toOpenApi _ = OA.toOpenApi (Proxy :: Proxy (Get '[JSON] NoContent))
|
||||
|
||||
instance OA.HasOpenApi (JWS Identity () JWSHeader) where
|
||||
toOpenApi _ = OA.toOpenApi (Proxy :: Proxy (Get '[JSON] NoContent))
|
||||
|
|
|
|||
|
|
@ -10,3 +10,5 @@ currency: "meow"
|
|||
currency_fraction: 2
|
||||
#block_registration: false
|
||||
sendmail_path: "/run/wrappers/bin/sendmail"
|
||||
# Change me !!!
|
||||
jwt_secret: "MySuperDuperSecretJWTKeyChangeMe"
|
||||
|
|
|
|||
30
flake.lock
30
flake.lock
|
|
@ -1,12 +1,15 @@
|
|||
{
|
||||
"nodes": {
|
||||
"flake-utils": {
|
||||
"inputs": {
|
||||
"systems": "systems"
|
||||
},
|
||||
"locked": {
|
||||
"lastModified": 1676283394,
|
||||
"narHash": "sha256-XX2f9c3iySLCw54rJ/CZs+ZK6IQy7GXNY4nSOyu2QG4=",
|
||||
"lastModified": 1687709756,
|
||||
"narHash": "sha256-Y5wKlQSkgEK2weWdOu4J3riRd+kV/VCgHsqLNTTWQ/0=",
|
||||
"owner": "numtide",
|
||||
"repo": "flake-utils",
|
||||
"rev": "3db36a8b464d0c4532ba1c7dda728f4576d6d073",
|
||||
"rev": "dbabf0ca0c0c4bce6ea5eaf65af5cb694d2082c7",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
|
|
@ -17,11 +20,11 @@
|
|||
},
|
||||
"nixpkgs": {
|
||||
"locked": {
|
||||
"lastModified": 1677990182,
|
||||
"narHash": "sha256-+gawrl8LSHsFYCb2vaJS7j9u4wphKEemyT9KFbcHPaI=",
|
||||
"lastModified": 1688712116,
|
||||
"narHash": "sha256-EGxj7LxiPy6NDe6AXKlYKUeN0xE++W/7dTa8a7VTHyA=",
|
||||
"owner": "NixOS",
|
||||
"repo": "nixpkgs",
|
||||
"rev": "f5d2643d6b38e8d30b94ada083dab200e1243b02",
|
||||
"rev": "151a0426808ebfdfadf282de2adee57bdfb28fc6",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
|
|
@ -35,6 +38,21 @@
|
|||
"flake-utils": "flake-utils",
|
||||
"nixpkgs": "nixpkgs"
|
||||
}
|
||||
},
|
||||
"systems": {
|
||||
"locked": {
|
||||
"lastModified": 1681028828,
|
||||
"narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=",
|
||||
"owner": "nix-systems",
|
||||
"repo": "default",
|
||||
"rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "nix-systems",
|
||||
"repo": "default",
|
||||
"type": "github"
|
||||
}
|
||||
}
|
||||
},
|
||||
"root": "root",
|
||||
|
|
|
|||
|
|
@ -11,7 +11,11 @@
|
|||
let
|
||||
pkgs = nixpkgs.legacyPackages.${system};
|
||||
|
||||
haskellPackages = pkgs.haskellPackages;
|
||||
haskellPackages = pkgs.haskellPackages.override {
|
||||
overrides = final: prev: {
|
||||
openapi3 = jailbreakUnbreak (pkgs.haskell.lib.dontCheck prev.openapi3);
|
||||
};
|
||||
};
|
||||
|
||||
jailbreakUnbreak = pkg:
|
||||
pkgs.haskell.lib.doJailbreak (pkg.overrideAttrs (_: { meta = { }; }));
|
||||
|
|
@ -21,7 +25,7 @@
|
|||
packages.${packageName} = # (ref:haskell-package-def)
|
||||
haskellPackages.callCabal2nix packageName self rec {
|
||||
# Dependency overrides go here
|
||||
openapi3 = jailbreakUnbreak haskellPackages.openapi3;
|
||||
postgresql-simple-migration = jailbreakUnbreak haskellPackages.postgresql-simple-migration;
|
||||
};
|
||||
|
||||
defaultPackage = self.packages.${system}.${packageName};
|
||||
|
|
|
|||
|
|
@ -112,6 +112,7 @@ library
|
|||
, mime-mail
|
||||
, directory
|
||||
, jose
|
||||
, monad-time
|
||||
|
||||
hs-source-dirs: src
|
||||
default-language: Haskell2010
|
||||
|
|
@ -163,6 +164,8 @@ executable mateamt
|
|||
, iproute
|
||||
, clock
|
||||
, tagged
|
||||
, jose >= 0.10
|
||||
, aeson
|
||||
|
||||
hs-source-dirs: app
|
||||
default-language: Haskell2010
|
||||
|
|
|
|||
|
|
@ -21,8 +21,7 @@ import Servant.RawM.Server ()
|
|||
import Types
|
||||
|
||||
type MateAPI = "v1" :> (
|
||||
"auth" :> "get" :> ReqBody '[JSON] TicketRequest :> Post '[JSON] AuthInfo
|
||||
:<|> "auth" :> ReqBody '[JSON] AuthRequest :> Post '[JSON] AuthResult
|
||||
"auth" :> ReqBody '[JSON] AuthRequest :> Post '[JSON] String
|
||||
:<|> "auth" :> AuthProtect "header-auth" :> Delete '[JSON] NoContent
|
||||
|
||||
:<|> "auth" :> "manage" :> AuthProtect "header-auth"
|
||||
|
|
@ -98,7 +97,6 @@ type MateAPI = "v1" :> (
|
|||
:<|> "meta" :> Get '[JSON] MetaInformation
|
||||
)
|
||||
|
||||
authGetLink :: Link
|
||||
authSendLink :: Link
|
||||
authLogoutLink :: Link
|
||||
|
||||
|
|
@ -143,8 +141,7 @@ settingsUpdateLnk :: Link
|
|||
|
||||
metaGetLink :: Link
|
||||
|
||||
( authGetLink :<|>
|
||||
authSendLink :<|>
|
||||
( authSendLink :<|>
|
||||
authLogoutLink :<|>
|
||||
|
||||
authManageListLink :<|>
|
||||
|
|
|
|||
|
|
@ -3,6 +3,8 @@ module Control.Auth where
|
|||
|
||||
import Servant
|
||||
|
||||
import Control.Lens (re, view, review)
|
||||
|
||||
import Control.Monad (void)
|
||||
|
||||
import Control.Monad.Reader (asks)
|
||||
|
|
@ -10,8 +12,14 @@ import Control.Monad.IO.Class (liftIO)
|
|||
|
||||
import Control.Concurrent.STM (readTVarIO)
|
||||
|
||||
import Crypto.KDF.Argon2
|
||||
import Crypto.Error
|
||||
import Crypto.JWT (SignedJWT, encodeCompact, base64url)
|
||||
import Crypto.KDF.Argon2
|
||||
|
||||
import Data.Aeson (encode)
|
||||
|
||||
import qualified Data.ByteString.Char8 as B8
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
|
||||
import Data.String (fromString)
|
||||
|
||||
|
|
@ -32,11 +40,8 @@ authGet (TicketRequest uid method) =
|
|||
|
||||
authSend
|
||||
:: AuthRequest
|
||||
-> MateHandler AuthResult
|
||||
authSend req = uncurry (processAuthRequest req) =<< ((,) <$>
|
||||
(liftIO . readTVarIO =<< asks rsTicketStore) <*>
|
||||
asks rsConnection
|
||||
)
|
||||
-> MateHandler String
|
||||
authSend req = B8.unpack . BL.toStrict . encodeCompact <$> (processAuthRequest req =<< asks rsConnection)
|
||||
|
||||
authLogout
|
||||
:: Maybe (Int, AuthMethod)
|
||||
|
|
|
|||
|
|
@ -4,6 +4,7 @@
|
|||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
module Model.Auth where
|
||||
|
||||
import Servant
|
||||
|
|
@ -17,7 +18,14 @@ import Control.Monad.Reader (asks)
|
|||
import Control.Concurrent (threadDelay)
|
||||
import Control.Concurrent.STM
|
||||
|
||||
import Control.Lens
|
||||
|
||||
import Crypto.Error
|
||||
import Crypto.JWT
|
||||
|
||||
import qualified Data.Aeson as A
|
||||
|
||||
import Data.ByteString as B (ByteString, fromStrict)
|
||||
|
||||
import Data.Profunctor.Product (p4, p6)
|
||||
|
||||
|
|
@ -34,9 +42,6 @@ import qualified Data.Set as S
|
|||
|
||||
import Data.Time.Clock
|
||||
|
||||
import Data.ByteString as B (ByteString)
|
||||
import Data.ByteString.Base64 (encode)
|
||||
|
||||
import Opaleye hiding (null)
|
||||
|
||||
-- internal imports
|
||||
|
|
@ -49,7 +54,7 @@ import Util.Crypto
|
|||
initToken :: PGS.Query
|
||||
initToken = mconcat
|
||||
[ "CREATE TABLE IF NOT EXISTS \"token\" ("
|
||||
, "token_string BYTEA NOT NULL PRIMARY KEY,"
|
||||
, "token_id SERIAL PRIMARY KEY,"
|
||||
, "token_user INTEGER REFERENCES \"user\"(user_id) NOT NULL,"
|
||||
, "token_expiry TIMESTAMPTZ NOT NULL,"
|
||||
, "token_method INT NOT NULL"
|
||||
|
|
@ -57,19 +62,19 @@ initToken = mconcat
|
|||
]
|
||||
|
||||
tokenTable :: Table
|
||||
( Field SqlBytea
|
||||
( Maybe (Field SqlInt4)
|
||||
, Field SqlInt4
|
||||
, Field SqlTimestamptz
|
||||
, Field SqlInt4
|
||||
)
|
||||
( Field SqlBytea
|
||||
( Field SqlInt4
|
||||
, Field SqlInt4
|
||||
, Field SqlTimestamptz
|
||||
, Field SqlInt4
|
||||
)
|
||||
tokenTable = table "token" (
|
||||
p4
|
||||
( tableField "token_string"
|
||||
( tableField "token_id"
|
||||
, tableField "token_user"
|
||||
, tableField "token_expiry"
|
||||
, tableField "token_method"
|
||||
|
|
@ -214,22 +219,31 @@ deleteAuthDataById adid conn = liftIO $ runDelete_ conn $ Delete
|
|||
|
||||
validateToken
|
||||
:: ByteString
|
||||
-> JWK
|
||||
-> PGS.Connection
|
||||
-> Handler (Maybe (Int, AuthMethod))
|
||||
validateToken header conn = do
|
||||
validateToken authHeader key conn = do
|
||||
token <- either (error . show) id <$> liftIO (runJOSE $ do
|
||||
jwt <- (decodeCompact (fromStrict authHeader) :: JOSE JWTError IO SignedJWT)
|
||||
liftIO $ print jwt
|
||||
let chk = defaultJWTValidationSettings (const True)
|
||||
verifyJWT chk key jwt :: JOSE JWTError IO AuthResult
|
||||
)
|
||||
tokens <- liftIO $ map fromDatabase <$> runSelect conn (
|
||||
proc () -> do
|
||||
stuff@(tstr, _, _, _) <- (selectTable tokenTable) -< ()
|
||||
restrict -< toFields header .== tstr
|
||||
stuff@(_, tUser, _, tMethod) <- (selectTable tokenTable) -< ()
|
||||
restrict -<
|
||||
toFields (authUser token) .== tUser .&&
|
||||
toFields (fromEnum $ authMethod token) .== tMethod
|
||||
returnA -< stuff
|
||||
)
|
||||
case tokens of
|
||||
[Token _ uid stamp method] -> do
|
||||
[Token tid uid stamp method] -> do
|
||||
now_ <- liftIO getCurrentTime
|
||||
if diffUTCTime stamp now_ > 0
|
||||
then return $ Just (uid, method)
|
||||
else do
|
||||
void $ deleteToken header conn
|
||||
void $ deleteToken tid conn
|
||||
liftIO $ threadDelay delayTime
|
||||
throwError $ err401
|
||||
{ errBody = "Your token expired!"
|
||||
|
|
@ -242,11 +256,12 @@ validateToken header conn = do
|
|||
|
||||
|
||||
generateToken
|
||||
:: Ticket
|
||||
:: Int
|
||||
-> AuthMethod
|
||||
-> AuthResponse
|
||||
-> PGS.Connection
|
||||
-> MateHandler AuthResult
|
||||
generateToken (Ticket _ tuid _ (method, _)) (AuthResponse response) conn = do
|
||||
-> MateHandler SignedJWT
|
||||
generateToken tuid method (AuthResponse response) conn = do
|
||||
authData <- liftIO $ map fromDatabase <$> runSelect conn (
|
||||
proc () -> do
|
||||
stuff@(_, auid, amethod, _, _, _) <- selectTable authDataTable -< ()
|
||||
|
|
@ -263,15 +278,22 @@ generateToken (Ticket _ tuid _ (method, _)) (AuthResponse response) conn = do
|
|||
-- liftIO $ print (response : userPayloads)
|
||||
if authResult
|
||||
then do
|
||||
token <- liftIO $ Token
|
||||
<$> (decodeUtf8 <$> randomString)
|
||||
<*> pure tuid
|
||||
<*> (addUTCTime (23*60) <$> getCurrentTime)
|
||||
<*> pure method
|
||||
void $ insertToken token conn
|
||||
return $ Granted (AuthToken $ tokenString token)
|
||||
key <- asks rsJWTSecret
|
||||
issuedAt <- liftIO getCurrentTime
|
||||
let preToken =
|
||||
( tuid
|
||||
, (addUTCTime (23*60) issuedAt)
|
||||
, method
|
||||
)
|
||||
liftIO $ print $ A.encode key
|
||||
void $ insertToken preToken conn
|
||||
let result = AuthResult issuedAt tuid method -- (AuthToken $ tokenString token)
|
||||
signedJWT <- liftIO $ runJOSE (do
|
||||
algo <- (bestJWSAlg key :: JOSE JWTError IO Alg)
|
||||
signJWT key (newJWSHeader ((), algo)) result)
|
||||
return $ either (error "Signing JWT failed") id signedJWT
|
||||
else
|
||||
return Denied
|
||||
throwError err401
|
||||
where
|
||||
validatePass resp =
|
||||
foldM
|
||||
|
|
@ -287,37 +309,43 @@ generateToken (Ticket _ tuid _ (method, _)) (AuthResponse response) conn = do
|
|||
)
|
||||
False
|
||||
validateChallengeResponse _ _ =
|
||||
error "Validation of challenge response authentication not yet implemented"
|
||||
throwError err501
|
||||
{ errBody = "Validation of challenge response authentication not yet implemented"
|
||||
}
|
||||
-- signJWT :: JWK -> AuthResult -> MateHandler (Either JWTError SignedJWT)
|
||||
-- signJWT key result = liftIO $ runExceptT $ do
|
||||
-- algo <- bestJWSAlg key
|
||||
-- signJWS (A.encode result) (Identity (newJWSHeader ((), algo), key))
|
||||
|
||||
|
||||
insertToken
|
||||
:: Token
|
||||
:: (Int, UTCTime, AuthMethod)
|
||||
-> PGS.Connection
|
||||
-> MateHandler ByteString
|
||||
insertToken (Token tString tUser tExpiry tMethod) conn =
|
||||
-> MateHandler Int
|
||||
insertToken (tUser, tExpiry, tMethod) conn =
|
||||
fmap head $ liftIO $ runInsert_ conn $ Insert
|
||||
{ iTable = tokenTable
|
||||
, iRows =
|
||||
[
|
||||
( toFields (encodeUtf8 tString)
|
||||
( toFields (Nothing :: Maybe Int)
|
||||
, toFields tUser
|
||||
, toFields tExpiry
|
||||
, toFields (fromEnum tMethod)
|
||||
)
|
||||
]
|
||||
, iReturning = rReturning (\(ident, _, _, _) -> ident)
|
||||
, iReturning = rReturning (\(tid, _, _, _) -> tid)
|
||||
, iOnConflict = Nothing
|
||||
}
|
||||
|
||||
|
||||
deleteToken
|
||||
:: ByteString
|
||||
:: Int
|
||||
-> PGS.Connection
|
||||
-> Handler Int64
|
||||
deleteToken tstr conn =
|
||||
deleteToken dtid conn =
|
||||
liftIO $ runDelete_ conn $ Delete
|
||||
{ dTable = tokenTable
|
||||
, dWhere = \(rtstr, _, _, _) -> rtstr .== toFields tstr
|
||||
, dWhere = \(tid, _, _, _) -> tid .== toFields dtid
|
||||
, dReturning = rCount
|
||||
}
|
||||
|
||||
|
|
@ -364,25 +392,14 @@ newTicket ident method = do
|
|||
|
||||
processAuthRequest
|
||||
:: AuthRequest
|
||||
-> S.Set Ticket
|
||||
-> PGS.Connection
|
||||
-> MateHandler AuthResult
|
||||
processAuthRequest (AuthRequest aticket pass) store conn = do
|
||||
let mticket = S.filter (\st -> ticketId st == aticket) store
|
||||
case S.toList mticket of
|
||||
[ticket] -> do
|
||||
-- liftIO $ putStrLn "there is a ticket..."
|
||||
now_ <- liftIO getCurrentTime
|
||||
liftIO $ threadDelay delayTime
|
||||
if now_ > ticketExpiry ticket
|
||||
then
|
||||
return Denied
|
||||
else
|
||||
-- liftIO $ putStrLn "...and it is valid"
|
||||
generateToken ticket pass conn
|
||||
_ -> do
|
||||
liftIO $ threadDelay delayTime
|
||||
return Denied
|
||||
-> MateHandler SignedJWT
|
||||
processAuthRequest (AuthRequest user method pass) conn = do
|
||||
-- liftIO $ putStrLn "there is a ticket..."
|
||||
now_ <- liftIO getCurrentTime
|
||||
liftIO $ threadDelay delayTime
|
||||
-- liftIO $ putStrLn "...and it is valid"
|
||||
generateToken user method pass conn
|
||||
|
||||
processLogout
|
||||
:: Int
|
||||
|
|
|
|||
|
|
@ -25,7 +25,7 @@ initSettings :: PGS.Query
|
|||
initSettings = mconcat
|
||||
[ "CREATE TABLE IF NOT EXISTS \"settings\" ("
|
||||
, "settings_signup_blocked BOOLEAN NOT NULL DEFAULT false,"
|
||||
, "settings_imprint TEXT DEFAULT \'\'"
|
||||
, "settings_imprint TEXT DEFAULT \'\',"
|
||||
, "settings_idle_time INTEGER NOT NULL DEFAULT 30"
|
||||
, ");"
|
||||
, "INSERT INTO \"settings\" DEFAULT VALUES"
|
||||
|
|
|
|||
|
|
@ -1,12 +1,14 @@
|
|||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
module Types.Auth where
|
||||
|
||||
import Crypto.JWT
|
||||
|
||||
import GHC.Generics
|
||||
|
||||
import Control.Lens.Lens
|
||||
|
||||
import Crypto.JWT
|
||||
|
||||
import Data.Aeson
|
||||
|
||||
import qualified Data.Set as S
|
||||
|
|
@ -111,7 +113,8 @@ instance FromJSON AuthResponse
|
|||
instance ToSchema AuthResponse
|
||||
|
||||
data AuthRequest = AuthRequest
|
||||
{ authRequestTicket :: AuthTicket
|
||||
{ authRequestUser :: Int
|
||||
, authRequestMethod :: AuthMethod
|
||||
, authRequestPassword :: AuthResponse
|
||||
}
|
||||
deriving (Show, Generic)
|
||||
|
|
@ -122,18 +125,24 @@ instance ToJSON AuthRequest where
|
|||
instance FromJSON AuthRequest
|
||||
instance ToSchema AuthRequest
|
||||
|
||||
data AuthResult
|
||||
= Granted
|
||||
{ authToken :: AuthToken
|
||||
}
|
||||
| Denied
|
||||
deriving (Show, Generic)
|
||||
data AuthResult = AuthResult
|
||||
{ authTime :: UTCTime
|
||||
, authUser :: Int
|
||||
, authMethod :: AuthMethod
|
||||
-- , authToken :: AuthToken
|
||||
}
|
||||
deriving (Show, Generic)
|
||||
|
||||
instance ToJSON AuthResult where
|
||||
toEncoding = genericToEncoding defaultOptions
|
||||
|
||||
instance FromJSON AuthResult
|
||||
instance ToSchema AuthResult
|
||||
instance HasClaimsSet AuthResult where
|
||||
claimsSet = lens (const emptyClaimsSet) const
|
||||
|
||||
instance FromJSON Token
|
||||
instance ToSchema Token
|
||||
|
||||
newtype AuthToken = AuthToken T.Text deriving (Show, Generic)
|
||||
|
||||
|
|
@ -144,7 +153,7 @@ instance FromJSON AuthToken
|
|||
instance ToSchema AuthToken
|
||||
|
||||
data Token = Token
|
||||
{ tokenString :: T.Text
|
||||
{ tokenId :: Int
|
||||
, tokenUser :: Int
|
||||
, tokenExpiry :: UTCTime
|
||||
, tokenMethod :: AuthMethod
|
||||
|
|
@ -160,12 +169,12 @@ data Token = Token
|
|||
|
||||
instance DatabaseRepresentation Token where
|
||||
|
||||
type Representation Token = (ByteString, Int, UTCTime, Int)
|
||||
type Representation Token = (Int, Int, UTCTime, Int)
|
||||
|
||||
instance FromDatabase Token where
|
||||
|
||||
fromDatabase (string, usr, expiry, method) =
|
||||
Token (decodeUtf8 string) usr expiry (toEnum method)
|
||||
fromDatabase (tId, usr, expiry, method) =
|
||||
Token tId usr expiry (toEnum method)
|
||||
|
||||
|
||||
type TicketStore = TVar (S.Set Ticket)
|
||||
|
|
|
|||
|
|
@ -1,3 +1,5 @@
|
|||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
module Types.Reader where
|
||||
|
||||
import qualified Data.Text as T
|
||||
|
|
@ -5,7 +7,11 @@ import qualified Data.Text as T
|
|||
import Servant (Handler)
|
||||
|
||||
import Control.Concurrent.STM (TQueue)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Monad.Reader (ReaderT)
|
||||
import Control.Monad.Time
|
||||
|
||||
import Crypto.JOSE.JWK
|
||||
|
||||
import Database.PostgreSQL.Simple (Connection)
|
||||
|
||||
|
|
@ -23,6 +29,10 @@ data ReadState = ReadState
|
|||
, rsSoftwareVersion :: T.Text
|
||||
, rsSendmailPath :: FilePath
|
||||
, rsMailQueue :: TQueue Mail
|
||||
, rsJWTSecret :: JWK
|
||||
}
|
||||
|
||||
type MateHandler = ReaderT ReadState Handler
|
||||
|
||||
instance MonadTime MateHandler where
|
||||
currentTime = liftIO currentTime
|
||||
|
|
|
|||
|
|
@ -72,6 +72,7 @@ initDB conn = do
|
|||
void $ execute_ conn initJournal
|
||||
void $ execute_ conn initRole
|
||||
void $ execute_ conn initUserToRole
|
||||
void $ execute_ conn initSettings
|
||||
void $ runInsertInitialRoles conn
|
||||
|
||||
-- This is only a dummy function.
|
||||
|
|
|
|||
Loading…
Reference in a new issue