From 8a42de950180d2d03bcdadf9dd713f99b7d48435 Mon Sep 17 00:00:00 2001 From: Rashad Gover Date: Sun, 23 Apr 2023 01:16:38 +0000 Subject: [PATCH] Add JWT foor realworld --- lib/okapi.cabal | 6 +++ lib/realworld/App.hs | 51 ++++++++++++++++++++ lib/realworld/Data.hs | 9 +++- lib/realworld/Database.hs | 29 +++++++++++ lib/realworld/JWT.hs | 61 ++++++++++++++++++++++++ lib/{todo.db => realworld/realworld.db} | Bin 8192 -> 8192 bytes lib/test.db | Bin 0 -> 8192 bytes 7 files changed, 155 insertions(+), 1 deletion(-) create mode 100644 lib/realworld/App.hs create mode 100644 lib/realworld/JWT.hs rename lib/{todo.db => realworld/realworld.db} (94%) create mode 100644 lib/test.db diff --git a/lib/okapi.cabal b/lib/okapi.cabal index 5616380..932b58e 100644 --- a/lib/okapi.cabal +++ b/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 diff --git a/lib/realworld/App.hs b/lib/realworld/App.hs new file mode 100644 index 0000000..0eacc4a --- /dev/null +++ b/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 diff --git a/lib/realworld/Data.hs b/lib/realworld/Data.hs index 75e4b6e..b3e0682 100644 --- a/lib/realworld/Data.hs +++ b/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) diff --git a/lib/realworld/Database.hs b/lib/realworld/Database.hs index efe6361..24155c3 100644 --- a/lib/realworld/Database.hs +++ b/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 \ No newline at end of file diff --git a/lib/realworld/JWT.hs b/lib/realworld/JWT.hs new file mode 100644 index 0000000..d2726ae --- /dev/null +++ b/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 \ No newline at end of file diff --git a/lib/todo.db b/lib/realworld/realworld.db similarity index 94% rename from lib/todo.db rename to lib/realworld/realworld.db index 475d63bc1c5c05f3ac2f61a8ebcda0e2bd911a0e..e8371fc04ee5e36b443057d9d63c80ee34774dde 100644 GIT binary patch delta 112 zcmZp0XmFSy&B#1a#+jd)LC^jsF9QPuBmV^k{tKH01(Nt}^cdO1MMW7MOA?cEQcF^c zOF)>(Imp#9#8n~0(aFbE0VJZJk(pPbkeQ+h($B>Ije-9+|2LosGx#Sq1aUDlF)?y6 JGcqx<0svJ|8}$GH delta 231 zcmZp0XmFSy%_ulg#+hG`K`+{rmw|zSk$(vT|B{V`X8c)EjO^m#;*5>LC5cHnsU`U- z`Nd#@$vMc?F~n6N#L>yeRRJudppluP;OQ6Q>h2n(5D?_)>lhTN;O!czqmY-Fo2n4v z8WEzSP+XE&Qd$h=Xo9R_;y=s4|CIkM|FX@30<-zUC1e#HgI&@Ri&N4v^OEy(3xJlU z0@Z0bDh6aGXDgHzD5Qunu`tLg`X*+lDwL!qB9uuovM?wsdZgy$A BLoomV diff --git a/lib/test.db b/lib/test.db new file mode 100644 index 0000000000000000000000000000000000000000..0c1a32534321b463bf4c3bfbfac7c814b35add0d GIT binary patch literal 8192 zcmeI$u};G<5C-70i;y~0_7ZhHi2*7hhV}(WD~m>?2!aPXrb>z;Q9z0FYJCbGArHXB zGhicSVIdpKfAYyb>jvxF&W{gi?rzhX>R z`_GB*66#2PAs_$&2tWV=5P$##AOHafKmY;|7%Z?Br_(4Bt;=^Wr7Ig3Qm!%+Tf;V9 zriQ}}UsMGrch=mPjPJ8#6K7k#HQP&WT+P-z*;$y)rRqq1sZM