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
-- , 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

View file

@ -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))

View file

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

View file

@ -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",

View file

@ -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};

View file

@ -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

View file

@ -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 :<|>

View file

@ -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)

View file

@ -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

View file

@ -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"

View file

@ -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)

View file

@ -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

View file

@ -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.