JWT support works

This commit is contained in:
nek0 2023-07-08 00:16:05 +02:00
parent edb27838cc
commit 5cba7e5827
13 changed files with 175 additions and 96 deletions

View file

@ -20,6 +20,7 @@ data ServerConfig = ServerConfig
-- , configMaxConnectionsPerClient :: Word -- , configMaxConnectionsPerClient :: Word
-- , configBlockRegistration :: Bool -- , configBlockRegistration :: Bool
, configSendmailPath :: FilePath , configSendmailPath :: FilePath
, configJWTSecret :: T.Text
} }
deriving (Show) deriving (Show)
@ -37,6 +38,7 @@ instance FromJSON ServerConfig where
-- <*> m .:? "max_connections_per_client" .!= 10 -- <*> m .:? "max_connections_per_client" .!= 10
-- <*> m .: "block_registration" -- <*> m .: "block_registration"
<*> m .: "sendmail_path" <*> m .: "sendmail_path"
<*> m .: "jwt_secret"
parseJSON _ = error "Can not parse configuration" parseJSON _ = error "Can not parse configuration"
data Options = Options data Options = Options

View file

@ -10,6 +10,9 @@ module Main where
import Prelude as P import Prelude as P
import Crypto.JWT hiding (Context, header)
import Crypto.JOSE.JWK hiding (Context)
import Control.Concurrent.STM (newTQueueIO) import Control.Concurrent.STM (newTQueueIO)
import Control.Concurrent (forkIO) import Control.Concurrent (forkIO)
@ -19,21 +22,22 @@ import qualified Servant.OpenApi as OA
import Servant.Swagger.UI import Servant.Swagger.UI
import Servant.RawM import Servant.RawM
import qualified Data.Aeson as A
import Data.Set as S (empty) import Data.Set as S (empty)
import qualified Data.ByteString.Lazy as B
import Data.ByteString.Char8 as B8 hiding (putStrLn) import Data.ByteString.Char8 as B8 hiding (putStrLn)
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Data.String import Data.String
import Data.Yaml import Data.Yaml
import Data.Version (showVersion) import Data.Version (showVersion)
import Data.IP
import qualified Data.OpenApi as OA hiding (Server) import qualified Data.OpenApi as OA hiding (Server)
import Database.PostgreSQL.Simple import Database.PostgreSQL.Simple
import Database.PostgreSQL.Simple.Migration import Database.PostgreSQL.Simple.Migration
import Database.PostgreSQL.Simple.Util import Database.PostgreSQL.Simple.Util
import Network.Socket (defaultPort)
import Network.Wai import Network.Wai
import Network.Wai.Logger import Network.Wai.Logger
import Network.Wai.Handler.Warp import Network.Wai.Handler.Warp
@ -86,6 +90,7 @@ main = do
-- max_conn_per_client -- max_conn_per_client
-- block_registration -- block_registration
sendmail_path sendmail_path
jwt_secret
) -> do ) -> do
conn <- connectPostgreSQL ( conn <- connectPostgreSQL (
"host='" <> fromString (T.unpack db_host) <> "' " <> "host='" <> fromString (T.unpack db_host) <> "' " <>
@ -141,6 +146,8 @@ main = do
, rsSoftwareVersion = T.pack (showVersion version) , rsSoftwareVersion = T.pack (showVersion version)
, rsSendmailPath = sendmail_path , rsSendmailPath = sendmail_path
, rsMailQueue = mailQueue , rsMailQueue = mailQueue
, rsJWTSecret =
fromOctets . B.fromStrict $ TE.encodeUtf8 jwt_secret
} }
expirationSpec = TimeSpec 5 0 -- five seconds expirationSpec = TimeSpec 5 0 -- five seconds
runSettings settings (app initState) runSettings settings (app initState)
@ -154,7 +161,8 @@ main = do
app :: ReadState -> Application app :: ReadState -> Application
-- app conn = serveWithContext userApi genAuthServerContext (users conn) -- app conn = serveWithContext userApi genAuthServerContext (users conn)
app initState = app initState =
serveWithContext combinedAPI (genAuthServerContext (rsConnection initState)) server serveWithContext combinedAPI
(genAuthServerContext (rsJWTSecret initState) (rsConnection initState)) server
where where
server :: Server CombinedAPI server :: Server CombinedAPI
server = appToServer initState mateAPI thisApi :<|> server = appToServer initState mateAPI thisApi :<|>
@ -168,7 +176,6 @@ appToServer initState myApi =
thisApi :: ServerT MateAPI MateHandler thisApi :: ServerT MateAPI MateHandler
thisApi = thisApi =
authGet :<|>
authSend :<|> authSend :<|>
authLogout :<|> authLogout :<|>
@ -232,21 +239,22 @@ authProxy :: Proxy '[ AuthHandler Request (Maybe (Int, AuthMethod)) ]
authProxy = Proxy authProxy = Proxy
genAuthServerContext genAuthServerContext
:: Connection :: JWK
-> Connection
-> Context '[ AuthHandler Request (Maybe (Int, AuthMethod)) ] -> 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) type instance AuthServerData (AuthProtect "header-auth") = Maybe (Int, AuthMethod)
authHandler :: Connection -> AuthHandler Request (Maybe (Int, AuthMethod)) authHandler :: JWK -> Connection -> AuthHandler Request (Maybe (Int, AuthMethod))
authHandler conn = mkAuthHandler handler authHandler key conn = mkAuthHandler handler
where where
handler :: Request -> Handler (Maybe (Int, AuthMethod)) handler :: Request -> Handler (Maybe (Int, AuthMethod))
handler req = do handler req = do
let headers = requestHeaders req let headers = requestHeaders req
case lookup "Authentication" headers of case lookup "Authorization" headers of
Just hh -> Just hh -> do
validateToken hh conn validateToken (B8.drop 7 hh) key conn
_ -> _ ->
return Nothing return Nothing
@ -255,3 +263,6 @@ instance OA.HasOpenApi sub => OA.HasOpenApi (AuthProtect "header-auth" :> sub) w
instance OA.HasOpenApi (RawM' Application) where instance OA.HasOpenApi (RawM' Application) where
toOpenApi _ = OA.toOpenApi (Proxy :: Proxy (Get '[JSON] NoContent)) toOpenApi _ = OA.toOpenApi (Proxy :: Proxy (Get '[JSON] NoContent))
instance OA.HasOpenApi (JWS Identity () JWSHeader) where
toOpenApi _ = OA.toOpenApi (Proxy :: Proxy (Get '[JSON] NoContent))

View file

@ -10,3 +10,5 @@ currency: "meow"
currency_fraction: 2 currency_fraction: 2
#block_registration: false #block_registration: false
sendmail_path: "/run/wrappers/bin/sendmail" sendmail_path: "/run/wrappers/bin/sendmail"
# Change me !!!
jwt_secret: "MySuperDuperSecretJWTKeyChangeMe"

View file

@ -1,12 +1,15 @@
{ {
"nodes": { "nodes": {
"flake-utils": { "flake-utils": {
"inputs": {
"systems": "systems"
},
"locked": { "locked": {
"lastModified": 1676283394, "lastModified": 1687709756,
"narHash": "sha256-XX2f9c3iySLCw54rJ/CZs+ZK6IQy7GXNY4nSOyu2QG4=", "narHash": "sha256-Y5wKlQSkgEK2weWdOu4J3riRd+kV/VCgHsqLNTTWQ/0=",
"owner": "numtide", "owner": "numtide",
"repo": "flake-utils", "repo": "flake-utils",
"rev": "3db36a8b464d0c4532ba1c7dda728f4576d6d073", "rev": "dbabf0ca0c0c4bce6ea5eaf65af5cb694d2082c7",
"type": "github" "type": "github"
}, },
"original": { "original": {
@ -17,11 +20,11 @@
}, },
"nixpkgs": { "nixpkgs": {
"locked": { "locked": {
"lastModified": 1677990182, "lastModified": 1688712116,
"narHash": "sha256-+gawrl8LSHsFYCb2vaJS7j9u4wphKEemyT9KFbcHPaI=", "narHash": "sha256-EGxj7LxiPy6NDe6AXKlYKUeN0xE++W/7dTa8a7VTHyA=",
"owner": "NixOS", "owner": "NixOS",
"repo": "nixpkgs", "repo": "nixpkgs",
"rev": "f5d2643d6b38e8d30b94ada083dab200e1243b02", "rev": "151a0426808ebfdfadf282de2adee57bdfb28fc6",
"type": "github" "type": "github"
}, },
"original": { "original": {
@ -35,6 +38,21 @@
"flake-utils": "flake-utils", "flake-utils": "flake-utils",
"nixpkgs": "nixpkgs" "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", "root": "root",

View file

@ -11,7 +11,11 @@
let let
pkgs = nixpkgs.legacyPackages.${system}; pkgs = nixpkgs.legacyPackages.${system};
haskellPackages = pkgs.haskellPackages; haskellPackages = pkgs.haskellPackages.override {
overrides = final: prev: {
openapi3 = jailbreakUnbreak (pkgs.haskell.lib.dontCheck prev.openapi3);
};
};
jailbreakUnbreak = pkg: jailbreakUnbreak = pkg:
pkgs.haskell.lib.doJailbreak (pkg.overrideAttrs (_: { meta = { }; })); pkgs.haskell.lib.doJailbreak (pkg.overrideAttrs (_: { meta = { }; }));
@ -21,7 +25,7 @@
packages.${packageName} = # (ref:haskell-package-def) packages.${packageName} = # (ref:haskell-package-def)
haskellPackages.callCabal2nix packageName self rec { haskellPackages.callCabal2nix packageName self rec {
# Dependency overrides go here # Dependency overrides go here
openapi3 = jailbreakUnbreak haskellPackages.openapi3; postgresql-simple-migration = jailbreakUnbreak haskellPackages.postgresql-simple-migration;
}; };
defaultPackage = self.packages.${system}.${packageName}; defaultPackage = self.packages.${system}.${packageName};

View file

@ -112,6 +112,7 @@ library
, mime-mail , mime-mail
, directory , directory
, jose , jose
, monad-time
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
@ -163,6 +164,8 @@ executable mateamt
, iproute , iproute
, clock , clock
, tagged , tagged
, jose >= 0.10
, aeson
hs-source-dirs: app hs-source-dirs: app
default-language: Haskell2010 default-language: Haskell2010

View file

@ -21,8 +21,7 @@ import Servant.RawM.Server ()
import Types import Types
type MateAPI = "v1" :> ( type MateAPI = "v1" :> (
"auth" :> "get" :> ReqBody '[JSON] TicketRequest :> Post '[JSON] AuthInfo "auth" :> ReqBody '[JSON] AuthRequest :> Post '[JSON] String
:<|> "auth" :> ReqBody '[JSON] AuthRequest :> Post '[JSON] AuthResult
:<|> "auth" :> AuthProtect "header-auth" :> Delete '[JSON] NoContent :<|> "auth" :> AuthProtect "header-auth" :> Delete '[JSON] NoContent
:<|> "auth" :> "manage" :> AuthProtect "header-auth" :<|> "auth" :> "manage" :> AuthProtect "header-auth"
@ -98,7 +97,6 @@ type MateAPI = "v1" :> (
:<|> "meta" :> Get '[JSON] MetaInformation :<|> "meta" :> Get '[JSON] MetaInformation
) )
authGetLink :: Link
authSendLink :: Link authSendLink :: Link
authLogoutLink :: Link authLogoutLink :: Link
@ -143,8 +141,7 @@ settingsUpdateLnk :: Link
metaGetLink :: Link metaGetLink :: Link
( authGetLink :<|> ( authSendLink :<|>
authSendLink :<|>
authLogoutLink :<|> authLogoutLink :<|>
authManageListLink :<|> authManageListLink :<|>

View file

@ -3,6 +3,8 @@ module Control.Auth where
import Servant import Servant
import Control.Lens (re, view, review)
import Control.Monad (void) import Control.Monad (void)
import Control.Monad.Reader (asks) import Control.Monad.Reader (asks)
@ -10,8 +12,14 @@ import Control.Monad.IO.Class (liftIO)
import Control.Concurrent.STM (readTVarIO) import Control.Concurrent.STM (readTVarIO)
import Crypto.KDF.Argon2
import Crypto.Error 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) import Data.String (fromString)
@ -32,11 +40,8 @@ authGet (TicketRequest uid method) =
authSend authSend
:: AuthRequest :: AuthRequest
-> MateHandler AuthResult -> MateHandler String
authSend req = uncurry (processAuthRequest req) =<< ((,) <$> authSend req = B8.unpack . BL.toStrict . encodeCompact <$> (processAuthRequest req =<< asks rsConnection)
(liftIO . readTVarIO =<< asks rsTicketStore) <*>
asks rsConnection
)
authLogout authLogout
:: Maybe (Int, AuthMethod) :: Maybe (Int, AuthMethod)

View file

@ -4,6 +4,7 @@
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
module Model.Auth where module Model.Auth where
import Servant import Servant
@ -17,7 +18,14 @@ import Control.Monad.Reader (asks)
import Control.Concurrent (threadDelay) import Control.Concurrent (threadDelay)
import Control.Concurrent.STM import Control.Concurrent.STM
import Control.Lens
import Crypto.Error 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) import Data.Profunctor.Product (p4, p6)
@ -34,9 +42,6 @@ import qualified Data.Set as S
import Data.Time.Clock import Data.Time.Clock
import Data.ByteString as B (ByteString)
import Data.ByteString.Base64 (encode)
import Opaleye hiding (null) import Opaleye hiding (null)
-- internal imports -- internal imports
@ -49,7 +54,7 @@ import Util.Crypto
initToken :: PGS.Query initToken :: PGS.Query
initToken = mconcat initToken = mconcat
[ "CREATE TABLE IF NOT EXISTS \"token\" (" [ "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_user INTEGER REFERENCES \"user\"(user_id) NOT NULL,"
, "token_expiry TIMESTAMPTZ NOT NULL," , "token_expiry TIMESTAMPTZ NOT NULL,"
, "token_method INT NOT NULL" , "token_method INT NOT NULL"
@ -57,19 +62,19 @@ initToken = mconcat
] ]
tokenTable :: Table tokenTable :: Table
( Field SqlBytea ( Maybe (Field SqlInt4)
, Field SqlInt4 , Field SqlInt4
, Field SqlTimestamptz , Field SqlTimestamptz
, Field SqlInt4 , Field SqlInt4
) )
( Field SqlBytea ( Field SqlInt4
, Field SqlInt4 , Field SqlInt4
, Field SqlTimestamptz , Field SqlTimestamptz
, Field SqlInt4 , Field SqlInt4
) )
tokenTable = table "token" ( tokenTable = table "token" (
p4 p4
( tableField "token_string" ( tableField "token_id"
, tableField "token_user" , tableField "token_user"
, tableField "token_expiry" , tableField "token_expiry"
, tableField "token_method" , tableField "token_method"
@ -214,22 +219,31 @@ deleteAuthDataById adid conn = liftIO $ runDelete_ conn $ Delete
validateToken validateToken
:: ByteString :: ByteString
-> JWK
-> PGS.Connection -> PGS.Connection
-> Handler (Maybe (Int, AuthMethod)) -> 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 ( tokens <- liftIO $ map fromDatabase <$> runSelect conn (
proc () -> do proc () -> do
stuff@(tstr, _, _, _) <- (selectTable tokenTable) -< () stuff@(_, tUser, _, tMethod) <- (selectTable tokenTable) -< ()
restrict -< toFields header .== tstr restrict -<
toFields (authUser token) .== tUser .&&
toFields (fromEnum $ authMethod token) .== tMethod
returnA -< stuff returnA -< stuff
) )
case tokens of case tokens of
[Token _ uid stamp method] -> do [Token tid uid stamp method] -> do
now_ <- liftIO getCurrentTime now_ <- liftIO getCurrentTime
if diffUTCTime stamp now_ > 0 if diffUTCTime stamp now_ > 0
then return $ Just (uid, method) then return $ Just (uid, method)
else do else do
void $ deleteToken header conn void $ deleteToken tid conn
liftIO $ threadDelay delayTime liftIO $ threadDelay delayTime
throwError $ err401 throwError $ err401
{ errBody = "Your token expired!" { errBody = "Your token expired!"
@ -242,11 +256,12 @@ validateToken header conn = do
generateToken generateToken
:: Ticket :: Int
-> AuthMethod
-> AuthResponse -> AuthResponse
-> PGS.Connection -> PGS.Connection
-> MateHandler AuthResult -> MateHandler SignedJWT
generateToken (Ticket _ tuid _ (method, _)) (AuthResponse response) conn = do generateToken tuid method (AuthResponse response) conn = do
authData <- liftIO $ map fromDatabase <$> runSelect conn ( authData <- liftIO $ map fromDatabase <$> runSelect conn (
proc () -> do proc () -> do
stuff@(_, auid, amethod, _, _, _) <- selectTable authDataTable -< () stuff@(_, auid, amethod, _, _, _) <- selectTable authDataTable -< ()
@ -263,15 +278,22 @@ generateToken (Ticket _ tuid _ (method, _)) (AuthResponse response) conn = do
-- liftIO $ print (response : userPayloads) -- liftIO $ print (response : userPayloads)
if authResult if authResult
then do then do
token <- liftIO $ Token key <- asks rsJWTSecret
<$> (decodeUtf8 <$> randomString) issuedAt <- liftIO getCurrentTime
<*> pure tuid let preToken =
<*> (addUTCTime (23*60) <$> getCurrentTime) ( tuid
<*> pure method , (addUTCTime (23*60) issuedAt)
void $ insertToken token conn , method
return $ Granted (AuthToken $ tokenString token) )
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 else
return Denied throwError err401
where where
validatePass resp = validatePass resp =
foldM foldM
@ -287,37 +309,43 @@ generateToken (Ticket _ tuid _ (method, _)) (AuthResponse response) conn = do
) )
False False
validateChallengeResponse _ _ = 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 insertToken
:: Token :: (Int, UTCTime, AuthMethod)
-> PGS.Connection -> PGS.Connection
-> MateHandler ByteString -> MateHandler Int
insertToken (Token tString tUser tExpiry tMethod) conn = insertToken (tUser, tExpiry, tMethod) conn =
fmap head $ liftIO $ runInsert_ conn $ Insert fmap head $ liftIO $ runInsert_ conn $ Insert
{ iTable = tokenTable { iTable = tokenTable
, iRows = , iRows =
[ [
( toFields (encodeUtf8 tString) ( toFields (Nothing :: Maybe Int)
, toFields tUser , toFields tUser
, toFields tExpiry , toFields tExpiry
, toFields (fromEnum tMethod) , toFields (fromEnum tMethod)
) )
] ]
, iReturning = rReturning (\(ident, _, _, _) -> ident) , iReturning = rReturning (\(tid, _, _, _) -> tid)
, iOnConflict = Nothing , iOnConflict = Nothing
} }
deleteToken deleteToken
:: ByteString :: Int
-> PGS.Connection -> PGS.Connection
-> Handler Int64 -> Handler Int64
deleteToken tstr conn = deleteToken dtid conn =
liftIO $ runDelete_ conn $ Delete liftIO $ runDelete_ conn $ Delete
{ dTable = tokenTable { dTable = tokenTable
, dWhere = \(rtstr, _, _, _) -> rtstr .== toFields tstr , dWhere = \(tid, _, _, _) -> tid .== toFields dtid
, dReturning = rCount , dReturning = rCount
} }
@ -364,25 +392,14 @@ newTicket ident method = do
processAuthRequest processAuthRequest
:: AuthRequest :: AuthRequest
-> S.Set Ticket
-> PGS.Connection -> PGS.Connection
-> MateHandler AuthResult -> MateHandler SignedJWT
processAuthRequest (AuthRequest aticket pass) store conn = do processAuthRequest (AuthRequest user method pass) conn = do
let mticket = S.filter (\st -> ticketId st == aticket) store
case S.toList mticket of
[ticket] -> do
-- liftIO $ putStrLn "there is a ticket..." -- liftIO $ putStrLn "there is a ticket..."
now_ <- liftIO getCurrentTime now_ <- liftIO getCurrentTime
liftIO $ threadDelay delayTime liftIO $ threadDelay delayTime
if now_ > ticketExpiry ticket
then
return Denied
else
-- liftIO $ putStrLn "...and it is valid" -- liftIO $ putStrLn "...and it is valid"
generateToken ticket pass conn generateToken user method pass conn
_ -> do
liftIO $ threadDelay delayTime
return Denied
processLogout processLogout
:: Int :: Int

View file

@ -25,7 +25,7 @@ initSettings :: PGS.Query
initSettings = mconcat initSettings = mconcat
[ "CREATE TABLE IF NOT EXISTS \"settings\" (" [ "CREATE TABLE IF NOT EXISTS \"settings\" ("
, "settings_signup_blocked BOOLEAN NOT NULL DEFAULT false," , "settings_signup_blocked BOOLEAN NOT NULL DEFAULT false,"
, "settings_imprint TEXT DEFAULT \'\'" , "settings_imprint TEXT DEFAULT \'\',"
, "settings_idle_time INTEGER NOT NULL DEFAULT 30" , "settings_idle_time INTEGER NOT NULL DEFAULT 30"
, ");" , ");"
, "INSERT INTO \"settings\" DEFAULT VALUES" , "INSERT INTO \"settings\" DEFAULT VALUES"

View file

@ -1,12 +1,14 @@
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
module Types.Auth where module Types.Auth where
import Crypto.JWT
import GHC.Generics import GHC.Generics
import Control.Lens.Lens
import Crypto.JWT
import Data.Aeson import Data.Aeson
import qualified Data.Set as S import qualified Data.Set as S
@ -111,7 +113,8 @@ instance FromJSON AuthResponse
instance ToSchema AuthResponse instance ToSchema AuthResponse
data AuthRequest = AuthRequest data AuthRequest = AuthRequest
{ authRequestTicket :: AuthTicket { authRequestUser :: Int
, authRequestMethod :: AuthMethod
, authRequestPassword :: AuthResponse , authRequestPassword :: AuthResponse
} }
deriving (Show, Generic) deriving (Show, Generic)
@ -122,11 +125,12 @@ instance ToJSON AuthRequest where
instance FromJSON AuthRequest instance FromJSON AuthRequest
instance ToSchema AuthRequest instance ToSchema AuthRequest
data AuthResult data AuthResult = AuthResult
= Granted { authTime :: UTCTime
{ authToken :: AuthToken , authUser :: Int
, authMethod :: AuthMethod
-- , authToken :: AuthToken
} }
| Denied
deriving (Show, Generic) deriving (Show, Generic)
instance ToJSON AuthResult where instance ToJSON AuthResult where
@ -134,6 +138,11 @@ instance ToJSON AuthResult where
instance FromJSON AuthResult instance FromJSON AuthResult
instance ToSchema 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) newtype AuthToken = AuthToken T.Text deriving (Show, Generic)
@ -144,7 +153,7 @@ instance FromJSON AuthToken
instance ToSchema AuthToken instance ToSchema AuthToken
data Token = Token data Token = Token
{ tokenString :: T.Text { tokenId :: Int
, tokenUser :: Int , tokenUser :: Int
, tokenExpiry :: UTCTime , tokenExpiry :: UTCTime
, tokenMethod :: AuthMethod , tokenMethod :: AuthMethod
@ -160,12 +169,12 @@ data Token = Token
instance DatabaseRepresentation Token where instance DatabaseRepresentation Token where
type Representation Token = (ByteString, Int, UTCTime, Int) type Representation Token = (Int, Int, UTCTime, Int)
instance FromDatabase Token where instance FromDatabase Token where
fromDatabase (string, usr, expiry, method) = fromDatabase (tId, usr, expiry, method) =
Token (decodeUtf8 string) usr expiry (toEnum method) Token tId usr expiry (toEnum method)
type TicketStore = TVar (S.Set Ticket) type TicketStore = TVar (S.Set Ticket)

View file

@ -1,3 +1,5 @@
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
module Types.Reader where module Types.Reader where
import qualified Data.Text as T import qualified Data.Text as T
@ -5,7 +7,11 @@ import qualified Data.Text as T
import Servant (Handler) import Servant (Handler)
import Control.Concurrent.STM (TQueue) import Control.Concurrent.STM (TQueue)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (ReaderT) import Control.Monad.Reader (ReaderT)
import Control.Monad.Time
import Crypto.JOSE.JWK
import Database.PostgreSQL.Simple (Connection) import Database.PostgreSQL.Simple (Connection)
@ -23,6 +29,10 @@ data ReadState = ReadState
, rsSoftwareVersion :: T.Text , rsSoftwareVersion :: T.Text
, rsSendmailPath :: FilePath , rsSendmailPath :: FilePath
, rsMailQueue :: TQueue Mail , rsMailQueue :: TQueue Mail
, rsJWTSecret :: JWK
} }
type MateHandler = ReaderT ReadState Handler type MateHandler = ReaderT ReadState Handler
instance MonadTime MateHandler where
currentTime = liftIO currentTime

View file

@ -72,6 +72,7 @@ initDB conn = do
void $ execute_ conn initJournal void $ execute_ conn initJournal
void $ execute_ conn initRole void $ execute_ conn initRole
void $ execute_ conn initUserToRole void $ execute_ conn initUserToRole
void $ execute_ conn initSettings
void $ runInsertInitialRoles conn void $ runInsertInitialRoles conn
-- This is only a dummy function. -- This is only a dummy function.