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 475d63b..e8371fc 100644 Binary files a/lib/todo.db and b/lib/realworld/realworld.db differ diff --git a/lib/test.db b/lib/test.db new file mode 100644 index 0000000..0c1a325 Binary files /dev/null and b/lib/test.db differ