Add JWT foor realworld

lib/okapi.cabal

@@ -126,8 +126,10 @@ test-suite okapi-test
 executable realworld
     main-is:          Main.hs
     other-modules:
+      App
       Data
       Database
+      JWT
       Plan.Authentication
       Plan.Registration
       Plan.GetCurrentUser
@@ -160,6 +162,10 @@ executable realworld
       , http-api-data
       , pretty-simple
       , aeson
+      , jose
       , openapi3
+      , sqlite-simple
+      , time
+      , lens
     hs-source-dirs:   realworld
     default-language: Haskell2010

lib/realworld/App.hs

@@ -0,0 +1,51 @@
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module App where
+
+import Control.Lens
+import Crypto.JWT
+import qualified Crypto.JWT as JWT
+import Data (Username)
+import qualified Data.Aeson as Aeson
+import qualified Data.Aeson.KeyMap as M
+import qualified Data.Text as Text
+import Data.Time (getCurrentTime)
+
+data Claims = Claims {claims :: ClaimsSet, username :: Username}
+
+instance JWT.HasClaimsSet Claims where
+  claimsSet f s = fmap (\a' -> s {claims = a'}) (f (claims s))
+
+instance Aeson.FromJSON Claims where
+  parseJSON = Aeson.withObject "Claims" $ \o ->
+    Claims
+      <$> Aeson.parseJSON (Aeson.Object o)
+      <*> o
+      Aeson..: "username"
+
+instance Aeson.ToJSON Claims where
+  toJSON s =
+    ins "username" (username s) (Aeson.toJSON (claims s))
+    where
+      ins k v (Aeson.Object o) = Aeson.Object $ M.insert k (Aeson.toJSON v) o
+      ins _ _ a = a
+
+mkClaims :: IO ClaimsSet
+mkClaims = do
+  t <- getCurrentTime
+  pure $
+    emptyClaimsSet
+      & claimIss ?~ "realworld"
+      & claimAud ?~ Audience ["realworld"]
+      & claimIat ?~ NumericDate t
+
+doJwtSign :: JWK -> Claims -> IO (Either JWTError SignedJWT)
+doJwtSign jwk claims = runJOSE $ do
+  alg <- bestJWSAlg jwk
+  JWT.signJWT jwk (newJWSHeader ((), alg)) claims
+
+doJwtVerify :: JWK -> SignedJWT -> IO (Either JWTError Claims)
+doJwtVerify jwk jwt = runJOSE $ do
+  let config = defaultJWTValidationSettings (== "realworld")
+  JWT.verifyJWT config jwk jwt

lib/realworld/Data.hs

@@ -8,6 +8,7 @@
 
 module Data where
 
+import Crypto.JWT (SignedJWT)
 import Data.Aeson (FromJSON, ToJSON)
 import Data.OpenApi (ToSchema)
 import Data.Text (Text)
@@ -27,13 +28,19 @@ data Profile = Profile
   deriving (Eq, Show, Generic, ToJSON)
 
 data User = User
+  { email :: Text,
+    token :: SignedJWT,
+    username :: Username,
+    bio :: Text,
+    image :: Text
+  }
   deriving (Eq, Show, Generic, ToJSON)
 
 newtype Tag = Tag {text :: Text}
   deriving newtype (Eq, Show, FromHttpApiData, ToSchema, ToJSON, FromJSON)
 
 newtype Username = Username {text :: Text}
-  deriving newtype (Eq, Show, FromHttpApiData, ToSchema, ToJSON)
+  deriving newtype (Eq, Show, FromHttpApiData, ToSchema, ToJSON, FromJSON)
 
 newtype Limit = Limit {int :: Int}
   deriving newtype (Eq, Show, FromHttpApiData, ToSchema, ToJSON)

lib/realworld/Database.hs

@@ -1 +1,30 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 module Database where
+
+import Control.Applicative
+import Data
+import qualified Data.Text as T
+import Database.SQLite.Simple
+import Database.SQLite.Simple.FromRow
+
+-- data TestField = TestField Int T.Text deriving (Show)
+
+-- instance FromRow TestField where
+--   fromRow = TestField <$> field <*> field
+
+-- instance ToRow TestField where
+--   toRow (TestField id_ str) = toRow (id_, str)
+
+-- main :: IO ()
+-- main = do
+--   conn <- open "test.db"
+--   execute_ conn "CREATE TABLE IF NOT EXISTS test (id INTEGER PRIMARY KEY, str TEXT)"
+--   execute conn "INSERT INTO test (str) VALUES (?)" (Only ("test string 2" :: String))
+--   execute conn "INSERT INTO test (id, str) VALUES (?,?)" (TestField 13 "test string 3")
+--   rowId <- lastInsertRowId conn
+--   executeNamed conn "UPDATE test SET str = :str WHERE id = :id" [":str" := ("updated str" :: T.Text), ":id" := rowId]
+--   r <- query_ conn "SELECT * from test" :: IO [TestField]
+--   mapM_ print r
+--   execute conn "DELETE FROM test WHERE id = ?" (Only rowId)
+--   close conn

lib/realworld/JWT.hs

@@ -0,0 +1,61 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module JWT where
+
+import Control.Lens
+import qualified Crypto.JOSE.JWK as JWK
+import qualified Crypto.JWT as JWT
+import Data (Username)
+import qualified Data.Aeson as Aeson
+import qualified Data.Aeson.KeyMap as M
+import qualified Data.Text as Text
+import Data.Text.Strict.Lens (utf8)
+import Data.Time (getCurrentTime)
+
+data Claims = Claims {claims :: JWT.ClaimsSet, username :: Username}
+
+instance JWT.HasClaimsSet Claims where
+  claimsSet f s = fmap (\a' -> s {claims = a'}) (f (claims s))
+
+instance Aeson.FromJSON Claims where
+  parseJSON = Aeson.withObject "Claims" $ \o ->
+    Claims
+      <$> Aeson.parseJSON (Aeson.Object o)
+      <*> o
+      Aeson..: "username"
+
+instance Aeson.ToJSON Claims where
+  toJSON s =
+    ins "username" (username s) (Aeson.toJSON (claims s))
+    where
+      ins k v (Aeson.Object o) = Aeson.Object $ M.insert k (Aeson.toJSON v) o
+      ins _ _ a = a
+
+doClaims :: IO JWT.ClaimsSet
+doClaims = do
+  t <- getCurrentTime
+  pure $
+    JWT.emptyClaimsSet
+      & JWT.claimIss ?~ "realworld"
+      & JWT.claimAud ?~ JWT.Audience ["realworld"]
+      & JWT.claimIat ?~ JWT.NumericDate t
+
+doSign :: JWT.JWK -> Claims -> IO (Either JWT.JWTError JWT.SignedJWT)
+doSign jwk claims = JWT.runJOSE $ do
+  alg <- JWT.bestJWSAlg jwk
+  JWT.signJWT jwk (JWT.newJWSHeader ((), alg)) claims
+
+doVerify :: JWT.JWK -> JWT.SignedJWT -> IO (Either JWT.JWTError Claims)
+doVerify jwk jwt = JWT.runJOSE $ do
+  let config = JWT.defaultJWTValidationSettings (== "realworld")
+  JWT.verifyJWT config jwk jwt
+
+-- Generate RSA JWK and set "kid" param to
+-- base64url-encoded SHA-256 thumbprint of key.
+--
+doGenKey :: IO JWK.JWK
+doGenKey = do
+  jwk <- JWK.genJWK (JWK.RSAGenParam (4096 `div` 8))
+  let h = view JWK.thumbprint jwk :: JWK.Digest JWK.SHA256
+      kid = view (re (JWK.base64url . JWK.digest) . utf8) h
+  pure $ set JWK.jwkKid (Just kid) jwk