From 5cba7e5827898379acaf43be894197057e087886 Mon Sep 17 00:00:00 2001 From: nek0 Date: Sat, 8 Jul 2023 00:16:05 +0200 Subject: [PATCH] JWT support works --- app/AppTypes/Configuration.hs | 2 + app/Main.hs | 35 ++++++---- config.yaml | 2 + flake.lock | 30 +++++++-- flake.nix | 8 ++- mateamt.cabal | 3 + src/API.hs | 7 +- src/Control/Auth.hs | 17 +++-- src/Model/Auth.hs | 117 +++++++++++++++++++--------------- src/Model/Settings.hs | 2 +- src/Types/Auth.hs | 37 +++++++---- src/Types/Reader.hs | 10 +++ src/Util.hs | 1 + 13 files changed, 175 insertions(+), 96 deletions(-) diff --git a/app/AppTypes/Configuration.hs b/app/AppTypes/Configuration.hs index f77edda..2f6ec0c 100644 --- a/app/AppTypes/Configuration.hs +++ b/app/AppTypes/Configuration.hs @@ -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 diff --git a/app/Main.hs b/app/Main.hs index a31aec4..990874f 100644 --- a/app/Main.hs +++ b/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)) diff --git a/config.yaml b/config.yaml index a548777..df748db 100644 --- a/config.yaml +++ b/config.yaml @@ -10,3 +10,5 @@ currency: "meow" currency_fraction: 2 #block_registration: false sendmail_path: "/run/wrappers/bin/sendmail" +# Change me !!! +jwt_secret: "MySuperDuperSecretJWTKeyChangeMe" diff --git a/flake.lock b/flake.lock index a8ceb4f..d7e9e87 100644 --- a/flake.lock +++ b/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", diff --git a/flake.nix b/flake.nix index 599cd59..510ff50 100644 --- a/flake.nix +++ b/flake.nix @@ -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}; diff --git a/mateamt.cabal b/mateamt.cabal index e8522dd..05f0c54 100644 --- a/mateamt.cabal +++ b/mateamt.cabal @@ -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 diff --git a/src/API.hs b/src/API.hs index b078348..becffc5 100644 --- a/src/API.hs +++ b/src/API.hs @@ -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 :<|> diff --git a/src/Control/Auth.hs b/src/Control/Auth.hs index e35cf64..77daf68 100644 --- a/src/Control/Auth.hs +++ b/src/Control/Auth.hs @@ -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) diff --git a/src/Model/Auth.hs b/src/Model/Auth.hs index 181baa4..e5d14fb 100644 --- a/src/Model/Auth.hs +++ b/src/Model/Auth.hs @@ -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 diff --git a/src/Model/Settings.hs b/src/Model/Settings.hs index 033bc6f..4eb5b71 100644 --- a/src/Model/Settings.hs +++ b/src/Model/Settings.hs @@ -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" diff --git a/src/Types/Auth.hs b/src/Types/Auth.hs index b756345..68f29c7 100644 --- a/src/Types/Auth.hs +++ b/src/Types/Auth.hs @@ -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) diff --git a/src/Types/Reader.hs b/src/Types/Reader.hs index 544de47..917679b 100644 --- a/src/Types/Reader.hs +++ b/src/Types/Reader.hs @@ -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 diff --git a/src/Util.hs b/src/Util.hs index c5577e5..50383bb 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -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.