JWT support works

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

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 :: JWK -> Connection -> AuthHandler Request (Maybe (Int, AuthMethod))
-authHandler conn = mkAuthHandler handler
+authHandler key conn = mkAuthHandler handler
   where
     handler :: Request -> Handler (Maybe (Int, AuthMethod))
     handler req = do
       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
 
@@ -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))

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"

flake.lock

@@ -1,12 +1,15 @@
 {
   "nodes": {
     "flake-utils": {
+      "inputs": {
+        "systems": "systems"
+      },
       "locked": {
-        "lastModified": 1676283394,
+        "lastModified": 1687709756,
-        "narHash": "sha256-XX2f9c3iySLCw54rJ/CZs+ZK6IQy7GXNY4nSOyu2QG4=",
+        "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,
+        "lastModified": 1688712116,
-        "narHash": "sha256-+gawrl8LSHsFYCb2vaJS7j9u4wphKEemyT9KFbcHPaI=",
+        "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",

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

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

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] String
-  :<|> "auth" :> ReqBody '[JSON] AuthRequest :> Post '[JSON] AuthResult
   :<|> "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 :<|>

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
+  -> 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
   :: Maybe (Int, AuthMethod)

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) -< ()
+      stuff@(_, tUser, _, tMethod) <- (selectTable tokenTable) -< ()
-      restrict -< toFields header .== tstr
+      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
+  -> MateHandler SignedJWT
-generateToken (Ticket _ tuid _ (method, _)) (AuthResponse response) conn = do
+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
+    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
-    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
+  -> MateHandler Int
-insertToken (Token tString tUser tExpiry tMethod) conn =
+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
+  -> 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..."
   now_ <- liftIO getCurrentTime
   liftIO $ threadDelay delayTime
-      if now_ > ticketExpiry ticket
-      then
-        return Denied
-      else
   -- liftIO $ putStrLn "...and it is valid"
-        generateToken ticket pass conn
+  generateToken user method pass conn
-    _        -> do
-      liftIO $ threadDelay delayTime
-      return Denied
 
 processLogout
   :: Int

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"

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,11 +125,12 @@ instance ToJSON AuthRequest where
 instance FromJSON AuthRequest
 instance ToSchema AuthRequest
 
-data AuthResult
+data AuthResult = AuthResult
-  = Granted
+  { authTime   :: UTCTime
-    { authToken :: AuthToken
+  , authUser   :: Int
+  , authMethod :: AuthMethod
+  -- , authToken  :: AuthToken
   }
-  | Denied
   deriving (Show, Generic)
 
 instance ToJSON AuthResult where
@@ -134,6 +138,11 @@ instance ToJSON AuthResult where
 
 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) =
+  fromDatabase (tId, usr, expiry, method) =
-    Token (decodeUtf8 string) usr expiry (toEnum method)
+    Token tId usr expiry (toEnum method)
 
 
 type TicketStore = TVar (S.Set Ticket)

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

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.