WIP refresh tokens

src/Server.hs

@@ -17,10 +17,12 @@ import Control.Concurrent.STM.TVar (newTVarIO, readTVar, modifyTVar)
 import Control.Exception (bracket)
 import Control.Monad (unless, (>=>))
 import Control.Monad.IO.Class
+import Control.Monad.Trans.Error (Error(..))
 import Control.Monad.Trans.Reader
 
 import Data.Aeson
 import Data.ByteString (ByteString (..), fromStrict, toStrict)
+import Data.Either (fromRight)
 import Data.List (find, elemIndex)
 import Data.Maybe (fromMaybe, fromJust, isJust, isNothing)
 import Data.String (IsString (..))
@@ -183,9 +185,11 @@ codeServer  = handleCreds
 ---- Token Endpoint ----
  ----------------------
 
+newtype ACode = ACode String deriving (Show)
+newtype RToken = RToken String deriving (Show)
 
 data ClientData = ClientData --TODO support other flows
-  { authCode :: String
+  { authID :: Either ACode RToken
   , clientID :: Maybe String
   , clientSecret :: Maybe String
   , redirect :: Maybe String
@@ -198,24 +202,33 @@ instance FromHttpApiData AuthFlow where
 
 instance FromForm ClientData where
   fromForm f = ClientData
-    <$> ((parseUnique @AuthFlow "grant_type" f) *> parseUnique "code" f)
+    <$> ((parseUnique @AuthFlow "grant_type" f) *> ((Left . ACode <$> parseUnique "code" f) <|> (Right . RToken <$> parseUnique "refresh_token" f)))
     <*> parseMaybe "client_id" f
     <*> parseMaybe "client_secret" f
     <*> parseMaybe "redirect_uri" f
 
+instance Error Text where
+  strMsg = pack
+
 
 data JWTWrapper = JWTW
-  { token :: String
+  { acessToken   :: String
-  , expiresIn :: NominalDiffTime
+  , expiresIn    :: NominalDiffTime
+  , refreshToken :: Maybe String
   } deriving (Show)
 
 instance ToJSON JWTWrapper where
-  toJSON (JWTW t e) = object ["access_token" .= t, "token_type" .= ("JWT" :: Text), "expires_in" .= e]
+  toJSON (JWTW a e r) = object
+    [ "access_token" .= a
+    , "token_type" .= ("JWT" :: Text)
+    , "expires_in" .= fromEnum e
+    , "refresh_token" .= r ]
 
 instance FromJSON JWTWrapper where
   parseJSON (Object o) = JWTW
-    <$> o .: "access_token"
+    <$> o .:  "access_token"
-    <*> o .: "expires_in"
+    <*> o .:  "expires_in"
+    <*> o .:? "refresh_token"
 
 instance FromHttpApiData JWTWrapper where
   parseHeader bs = case decode (fromStrict bs) of
@@ -235,13 +248,16 @@ tokenEndpoint = provideToken
       unless (isNothing (clientID client >> clientSecret client)
         || Client (pack . fromJust $ clientID client) (pack . fromJust $ clientSecret client) `elem` trustedClients) .
           throwError $ err500 { errBody = "Invalid client" }
-      mUser <- asks (verify (pack $ authCode client) (clientID client)) >>= liftIO -- TODO verify redirect url here
+      case authID client of
-      unless (isJust mUser) . throwError $ err500 { errBody = "Invalid authorisation code" }
+        Left (ACode authCode) -> do
-      -- return JWT {token = "", tokenType = "JWT", expiration = 0.25 * nominalDay}
+          mUser <- asks (verify (pack authCode) (clientID client)) >>= liftIO -- TODO verify redirect url here
-      let (user, scopes) = fromJust mUser
+          unless (isJust mUser) . throwError $ err500 { errBody = "Invalid authorisation code" }
-      token <- asks (mkToken @user @userData user scopes) >>= liftIO
+          -- return JWT {token = "", tokenType = "JWT", expiration = 0.25 * nominalDay}
-      liftIO . putStrLn $ "token: " ++ show token
+          let (user, scopes) = fromJust mUser
-      return token 
+          token <- asks (mkToken @user @userData user scopes) >>= liftIO
+          liftIO . putStrLn $ "token: " ++ show token
+          return token 
+        Right (RToken rToken) -> undefined
 
 
 mkToken :: forall user userData . UserData user userData
@@ -251,13 +267,18 @@ mkToken u scopes state = do
   now <- getCurrentTime
   uuid <- nextRandom
   let
-    lifetime = nominalDay / 24 -- TODO make configurable
+    lifetimeAT = 120 :: NominalDiffTime -- TODO make configurable
-    jwt = JWT "Oauth2MockServer" (lifetime `addUTCTime` now) uuid
+    lifetimeRT = nominalDay -- TODO make configurable
-  encoded <- jwkEncode RSA_OAEP_256 A128GCM pubKey (Nested . Jwt . toStrict $ encode jwt)
+    at = JWT "Oauth2MockServer" (lifetimeAT `addUTCTime` now) uuid
-  case encoded of
+    rt = JWT "Oauth2MockServer" (lifetimeRT `addUTCTime` now) uuid
-    Right (Jwt token) -> do
+  encodedAT <- jwkEncode RSA_OAEP_256 A128GCM pubKey (Nested . Jwt . toStrict $ encode at)
+  encodedRT <- jwkEncode RSA_OAEP_256 A128GCM pubKey (Nested . Jwt . toStrict $ encode rt)
+  case encodedAT >> encodedRT of
+    Right _ -> do
+      let Jwt aToken = fromRight undefined encodedAT
+          Jwt rToken = fromRight undefined encodedRT
       atomically . modifyTVar state $ \s -> s { activeTokens = Map.insert uuid (u, scopes) (activeTokens s) } 
-      return $ JWTW (BS.unpack token) lifetime
+      return $ JWTW (BS.unpack aToken) lifetimeAT (Just $ BS.unpack rToken)
     Left e -> error $ show e
 
 
@@ -286,7 +307,7 @@ userEndpoint = handleUserData
     handleUserData :: Text -> AuthHandler user (Maybe userData)
     handleUserData jwtw = do
       let mToken = stripPrefix "Bearer " jwtw
-      unless (isJust mToken) . throwError $ err500 { errBody = "Invalid token format"}
+      unless (isJust mToken) . throwError $ err500 { errBody = "Invalid token format" }
       token <- asks (decodeToken @user @userData (fromJust mToken)) >>= liftIO
       liftIO $ putStrLn "decoded token:" >> print token
       case token of