From ed287cd9fbdb8e8c8947818cd62fd75ace8fe5f3 Mon Sep 17 00:00:00 2001 From: Nicolas Mattia Date: Thu, 28 Mar 2019 22:54:55 +0100 Subject: [PATCH 01/19] handler: absolutely hard-coded auth test --- infra/default.nix | 25 ++++++++- infra/handler/app/Test.hs | 15 +++-- infra/handler/package.yaml | 8 +++ infra/handler/src/DeckGo/Handler.hs | 86 ++++++++++++++++++++++++++++- infra/nix/default.nix | 4 +- infra/nix/sources.json | 12 ++++ infra/private.key | 15 +++++ infra/public.cer | 15 +++++ infra/token | 1 + 9 files changed, 170 insertions(+), 11 deletions(-) create mode 100644 infra/private.key create mode 100644 infra/public.cer create mode 100644 infra/token diff --git a/infra/default.nix b/infra/default.nix index be9ff89eb..f5dbc3acf 100644 --- a/infra/default.nix +++ b/infra/default.nix @@ -14,7 +14,17 @@ rec tar -xvf ${pkgs.sources.dynamodb} ''; - test = pkgs.runCommand "tests" { buildInputs = [ pkgs.jre pkgs.curl pkgs.netcat pkgs.awscli ]; } + publicKey = builtins.readFile ./public.cer; + + googleResp = { "1" = publicKey ; }; + + apiDir = pkgs.writeTextFile + { name = "google-resp"; + destination = "/robot/v1/metadata/x509/securetoken@system.gserviceaccount.com"; + text = builtins.toJSON googleResp; + }; + + test = pkgs.runCommand "tests" { buildInputs = [ pkgs.jre pkgs.curl pkgs.netcat pkgs.awscli pkgs.haskellPackages.wai-app-static]; } '' java -Djava.library.path=${dynamoJar}/DynamoDBLocal_lib -jar ${dynamoJar}/DynamoDBLocal.jar -sharedDb -port 8000 & @@ -47,13 +57,24 @@ rec LD_PRELOAD="${pkgs.libredirect}/lib/libredirect.so" \ ${handler}/bin/server & + + cp ${pkgs.writeText "foo" (builtins.toJSON googleResp)} cert while ! nc -z 127.0.0.1 8080; do + echo waiting for server + sleep 1 + done + + warp -d ${apiDir} -p 8081 & + + while ! nc -z 127.0.0.1 8081; do echo waiting for warp sleep 1 done + curl localhost:8081/robot/v1/metadata/x509/securetoken@system.gserviceaccount.com + echo "Running tests" - ${handler}/bin/test + ${handler}/bin/test ${./token} touch $out ''; diff --git a/infra/handler/app/Test.hs b/infra/handler/app/Test.hs index 64925d484..f6fcbb929 100644 --- a/infra/handler/app/Test.hs +++ b/infra/handler/app/Test.hs @@ -5,15 +5,22 @@ import Network.HTTP.Client (newManager, defaultManagerSettings) import Servant.API import Servant.Client import DeckGo.Handler +import qualified Data.Text as T +import qualified Data.Text.IO as T import qualified Data.HashMap.Strict as HMS +import System.Environment (getArgs) main :: IO () main = do + [p] <- getArgs + + b <- T.readFile p + manager' <- newManager defaultManagerSettings let clientEnv = mkClientEnv manager' (BaseUrl Http "localhost" 8080 "") - runClientM decksGet' clientEnv >>= \case + runClientM (decksGet' b) clientEnv >>= \case Left err -> error $ "Expected decks, got error: " <> show err Right [] -> pure () Right decks -> error $ "Expected 0 decks, got: " <> show decks @@ -36,7 +43,7 @@ main = do Left err -> error $ "Expected updated deck, got error: " <> show err Right {} -> pure () - runClientM decksGet' clientEnv >>= \case + runClientM (decksGet' b) clientEnv >>= \case Left err -> error $ "Expected decks, got error: " <> show err Right decks -> if decks == [WithId deckId newDeck] then pure () else (error $ "Expected updated decks, got: " <> show decks) @@ -80,13 +87,13 @@ main = do Left err -> error $ "Expected deck delete, got error: " <> show err Right {} -> pure () - runClientM decksGet' clientEnv >>= \case + runClientM (decksGet' b) clientEnv >>= \case Left err -> error $ "Expected no decks, got error: " <> show err Right decks -> if decks == [] then pure () else (error $ "Expected no decks, got: " <> show decks) -- 'client' allows you to produce operations to query an API from a client. -decksGet' :: ClientM [WithId DeckId Deck] +decksGet' :: T.Text -> ClientM [WithId DeckId Deck] decksGetDeckId' :: DeckId -> ClientM (WithId DeckId Deck) decksPost' :: Deck -> ClientM (WithId DeckId Deck) decksPut' :: DeckId -> Deck -> ClientM (WithId DeckId Deck) diff --git a/infra/handler/package.yaml b/infra/handler/package.yaml index 71eefaae2..25b6b95d2 100644 --- a/infra/handler/package.yaml +++ b/infra/handler/package.yaml @@ -5,12 +5,20 @@ license: AGPL-3 dependencies: - aeson + - bytestring + - mtl - amazonka - amazonka-dynamodb - base + - jose - lens - random - servant + - x509 + - pem + #- servant-auth + #- servant-auth-server + - servant-client-core - servant-server - text - unliftio diff --git a/infra/handler/src/DeckGo/Handler.hs b/infra/handler/src/DeckGo/Handler.hs index 3aa3e2cea..28167336a 100644 --- a/infra/handler/src/DeckGo/Handler.hs +++ b/infra/handler/src/DeckGo/Handler.hs @@ -1,4 +1,8 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleInstances #-} @@ -11,9 +15,18 @@ module DeckGo.Handler where import Control.Monad +import Control.Monad.Except import Control.Lens hiding ((.=)) import Data.Proxy +import qualified Data.X509 as X509 +import qualified Data.PEM as PEM +import qualified Data.ByteString.Lazy as BL +-- import qualified Data.ByteString as BS import Servant.API +import qualified Crypto.JOSE.JWA.JWS as JOSE +import qualified Crypto.JOSE as JOSE +import qualified Crypto.JWT as JWT +import qualified Crypto.JOSE.JWK as JWK import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.HashMap.Strict as HMS @@ -24,12 +37,78 @@ import qualified Network.AWS as Aws import qualified Network.AWS.DynamoDB as DynamoDB import qualified Network.Wai as Wai import qualified Servant as Servant +import qualified Servant.Client.Core as Servant +-- import qualified Servant.Auth as Servant import qualified System.Random as Random +-- | Generate a key suitable for use with 'defaultConfig'. + +_sign :: JOSE.JWK -> JWT.ClaimsSet -> IO (Either JWT.JWTError JWT.SignedJWT) +_sign jwk cs = runExceptT $ JWT.signClaims jwk (JOSE.newJWSHeader ((), JOSE.RS256)) cs + +newtype UserId = UserId { unUserId :: T.Text } + deriving newtype (Aeson.FromJSON, Aeson.ToJSON, Show, Eq) + +newtype UnverifiedJWT = UnverifiedJWT JWT.SignedJWT + +-- TODO: MAKE SURE PATTERN MATCH FAILURES AREN'T PROPAGATED TO CLIENT!!! +verifyUser :: UnverifiedJWT -> IO UserId +verifyUser (UnverifiedJWT jwt) = do + Just jwkmap <- Aeson.decodeFileStrict' "./cert" :: IO (Maybe (HMS.HashMap T.Text T.Text)) + Just jwkct <- pure $ HMS.lookup "1" jwkmap + pem <- case PEM.pemParseBS (T.encodeUtf8 jwkct) of + Left e -> error $ show e + Right [e] -> pure e + Right xs -> error $ show xs + cert <- case X509.decodeSignedCertificate (PEM.pemContent pem) of + Left e -> error $ show e + Right c -> pure c + Right jwk <- runExceptT (JWK.fromX509Certificate cert) :: IO (Either JWT.JWTError JWT.JWK) + let config = JWT.defaultJWTValidationSettings (== "my-project-id") + runExceptT (JWT.verifyClaims config jwk jwt) >>= \case + Right {} -> pure (UserId "") + Left (e :: JWT.JWTError) -> error (show e) + +instance FromHttpApiData UnverifiedJWT where + parseUrlPiece = const $ Left "No support for JWT" + parseHeader bs = case JWT.decodeCompact (BL.fromStrict bs) of + Left (e :: JWT.Error) -> Left $ T.pack $ show e + Right jwt -> Right $ UnverifiedJWT jwt + +instance Servant.RunClient m => Servant.HasClient m (Protected :> Get '[JSON] [WithId DeckId Deck]) where + type Client m (Protected :> Get '[JSON] [WithId DeckId Deck]) = T.Text -> Servant.Client m (Get '[JSON] [WithId DeckId Deck]) + clientWithRoute p Proxy req = \bs -> + -- TODO: header should be Authorization Bearer + Servant.clientWithRoute p (Proxy :: Proxy (Header "Authorization" T.Text :> Get '[JSON] [WithId DeckId Deck])) req (Just bs) + + hoistClientMonad Proxy Proxy hoist c = \bs -> hoist (c bs) + +instance Servant.HasServer (Protected :> Get '[JSON] [WithId DeckId Deck]) context where + type ServerT (Protected :> Get '[JSON] [WithId DeckId Deck]) m = UserId -> Servant.ServerT (Get '[JSON] [WithId DeckId Deck]) m + + route Proxy c sub = do + Servant.route (Proxy :: Proxy ( Header "Authorization" UnverifiedJWT :> Get '[JSON] [WithId DeckId Deck])) c (adapt <$> sub) + where + adapt f = \case + Nothing -> error "NO SUCH FOOOO" + Just jwt -> do + uid <- liftIO $ verifyUser jwt + f uid + + + hoistServerWithContext = Servant.hoistServerWithContext + + ------------------------------------------------------------------------------ -- API ------------------------------------------------------------------------------ +data Protected +-- type Protected = Header "Bearer" JWT.SignedJWT + +-- protect :: m b -> Maybe JWT.SignedJWT -> m b +-- protect f _ = f + data WithId id a = WithId id a deriving (Show, Eq) @@ -107,7 +186,7 @@ type API = "slides" :> SlidesAPI type DecksAPI = - Get '[JSON] [WithId DeckId Deck] :<|> + Protected :> Get '[JSON] [WithId DeckId Deck] :<|> Capture "deck_id" DeckId :> Get '[JSON] (WithId DeckId Deck) :<|> ReqBody '[JSON] Deck :> Post '[JSON] (WithId DeckId Deck) :<|> Capture "deck_id" DeckId :> ReqBody '[JSON] Deck :> Put '[JSON] (WithId DeckId Deck) :<|> @@ -146,8 +225,9 @@ server env = serveDecks :<|> serveSlides slidesPut env :<|> slidesDelete env -decksGet :: Aws.Env -> Servant.Handler [WithId DeckId Deck] -decksGet env = do +decksGet :: Aws.Env -> UserId -> Servant.Handler [WithId DeckId Deck] +decksGet env uid = do + liftIO $ print uid res <- runAWS env $ Aws.send $ DynamoDB.scan "Decks" case res of Right scanResponse -> diff --git a/infra/nix/default.nix b/infra/nix/default.nix index 475a89837..c21cd74d2 100644 --- a/infra/nix/default.nix +++ b/infra/nix/default.nix @@ -25,8 +25,8 @@ with rec super // mkPackage "deckdeckgo-handler" ../handler // - ( mkPackage "wai-lambda" wai-lambda.wai-lambda-source - ); + ( mkPackage "wai-lambda" wai-lambda.wai-lambda-source ) // + { jose = super.callCabal2nix "jose" sources.hs-jose {}; } ; }; normalHaskellPackages = pkgsStatic.pkgsMusl.haskellPackages.override (haskellOverride pkgsStatic.pkgsMusl); diff --git a/infra/nix/sources.json b/infra/nix/sources.json index 04a581533..8480d96b3 100644 --- a/infra/nix/sources.json +++ b/infra/nix/sources.json @@ -26,6 +26,18 @@ "type": "file", "sha256": "0hrwxg4igyll40y7l1s0icg55g247fl8cjs4rrcpjf8d7m0bb09j" }, + "hs-jose": { + "homepage": "http://hackage.haskell.org/package/jose", + "url": "https://github.com/frasertweedale/hs-jose/archive/71274bf64c0600c1d877152173a08a5bff7adf4d.tar.gz", + "owner": "frasertweedale", + "branch": "master", + "url_template": "https://github.com///archive/.tar.gz", + "repo": "hs-jose", + "type": "tarball", + "sha256": "0ah189vika1s0jk8f17mn77gilkw24vbs6xlggxw1qj926i6c4pk", + "description": "Haskell JOSE and JWT library", + "rev": "71274bf64c0600c1d877152173a08a5bff7adf4d" + }, "static-haskell-nix": { "homepage": "", "url": "https://github.com/nh2/static-haskell-nix/archive/9781df8a48eade302d159ce63a7ab0c30247788c.tar.gz", diff --git a/infra/private.key b/infra/private.key new file mode 100644 index 000000000..1d4634fe4 --- /dev/null +++ b/infra/private.key @@ -0,0 +1,15 @@ +-----BEGIN RSA PRIVATE KEY----- +MIICXAIBAAKBgQDKh4Dnyyr4ufPYHvvwIM8uX4nhTqWolv7KI+1dYv4I2hgTafnB +pJdr7HFSsaoJ1mj92RSPbyqp2aAZKfEZirjNZgMBTqCmXOjVx16yCocJZkFykrYS +1nN7uJu7wfPpG4ehNBaURJee3+W9FfzZn4ZzVjt5NZqjKOsGulyq1irXlwIDAQAB +AoGAFdFLHa1RT8IYdqu/0Dp4lzJLlC34wpShlf0Q0QKdAy8bcNv1v9qPRV0PSC1D +eBPU86OzB1Cec/WxvYQ7KNk81xKZkm0RPyx4/2ETBTPk6H07LTasSP+4YGpqUGbI +ugvyDX28eZrFdCvjcaI3z9ZM2lNQDHvNIwta6o1UGwWO+SECQQDnTIIlK+NvX5u/ +1RESw8TXPok3qLatZuhx5y3rfDUwfOPJ9Jx94+t//jEOWuutyvui/UOlCYDi/Mpq +DokIOPeFAkEA4Ch2gjvlYrli2zZv1nizuolG/G4dgHW55ru0O/TYJ4VkzSAbMaHm +F0CMQnelyBSAQG2lQLwbunlDHy85rRfHawJADGCQulJ96jDQkdRiBIILX4VOLHdP +xzmxiJ7ZWzebVQvp2J3JXgc7S+8bSuxcnkE1dARfgU5f4kWqw0Ah3xnFTQJBALEb +p08NDherzEzRvRmi8rau4lRumIa3/bMtmaFJukO3pMZh2LqlZYv3pxqZOHZWpGLD +fy8fsXTrfLo18QcvY5MCQExZowvRm3uVtIDoRluzbs2u+whPfHStuP1kQUWJZ2Xs +HfHzl8i2CD6Z/rTTonV2YbHPQ0bMTHpY7TyvWa4eiK4= +-----END RSA PRIVATE KEY----- diff --git a/infra/public.cer b/infra/public.cer new file mode 100644 index 000000000..3244c5073 --- /dev/null +++ b/infra/public.cer @@ -0,0 +1,15 @@ +-----BEGIN CERTIFICATE----- +MIICWzCCAcSgAwIBAgIJAKXYAnYRQw2AMA0GCSqGSIb3DQEBCwUAMEUxCzAJBgNV +BAYTAkFVMRMwEQYDVQQIDApTb21lLVN0YXRlMSEwHwYDVQQKDBhJbnRlcm5ldCBX +aWRnaXRzIFB0eSBMdGQwHhcNMTkwMzI4MTk0NzE3WhcNMjAwMzI3MTk0NzE3WjBF +MQswCQYDVQQGEwJBVTETMBEGA1UECAwKU29tZS1TdGF0ZTEhMB8GA1UECgwYSW50 +ZXJuZXQgV2lkZ2l0cyBQdHkgTHRkMIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKB +gQDKh4Dnyyr4ufPYHvvwIM8uX4nhTqWolv7KI+1dYv4I2hgTafnBpJdr7HFSsaoJ +1mj92RSPbyqp2aAZKfEZirjNZgMBTqCmXOjVx16yCocJZkFykrYS1nN7uJu7wfPp +G4ehNBaURJee3+W9FfzZn4ZzVjt5NZqjKOsGulyq1irXlwIDAQABo1MwUTAdBgNV +HQ4EFgQUV7wv/E8xpbZ45hexyB9uZhMq0X0wHwYDVR0jBBgwFoAUV7wv/E8xpbZ4 +5hexyB9uZhMq0X0wDwYDVR0TAQH/BAUwAwEB/zANBgkqhkiG9w0BAQsFAAOBgQAt +ArZjS/5+aO1RPb3yYKyQELaYtz5V3Pg40cnWRKq1acsEIrjrZvPK3I8YGxM+g1XS +06ekc2Slo2/bPvxjAMXRj6cZKa0b+Fd18TuiaYgNS8V+Frd0LHjR3akJU8a+10p5 +fcj9nBTBM5p+5jFZ0hp+dtzCd1L5F30MkPPcwwM65A== +-----END CERTIFICATE----- diff --git a/infra/token b/infra/token new file mode 100644 index 000000000..7f2fddd0d --- /dev/null +++ b/infra/token @@ -0,0 +1 @@ +eyJhbGciOiJSUzI1NiIsImtpZCI6ImtleTEifQ.eyJleHAiOjE5MDMxMTk2MzAsInN1YiI6InRoZS11aWQiLCJuYW1lIjoiSm9obiBEb2UiLCJhZG1pbiI6dHJ1ZSwiaXNzIjoiaHR0cHM6Ly9zZWN1cmV0b2tlbi5nb29nbGUuY29tL215LXByb2plY3QtaWQiLCJpYXQiOjE1MTYyMzkwMjIsImF1ZCI6Im15LXByb2plY3QtaWQiLCJhdXRoX3RpbWUiOjE1NTM4MDQ1NzN9.IwJ_qdtKwnxukFX8ylNZyUyAaN_ODzUf841LLsmTd22qM6kCSRHDY5JJdIN3ZDajH-Rk8O2kCzmRZ2HwfhBtpSyn7E8dKt0Ajw8VtW8d_hmj5LWv0doUiiEhtRtADA9AFJYmv_jFmNoL6cX6HqSQr2ZD53GC0WSA46A0lD3K4KE From efcbdc3b3ca11267a850a6cfa94543a6dd1868c9 Mon Sep 17 00:00:00 2001 From: Nicolas Mattia Date: Fri, 29 Mar 2019 16:29:34 +0100 Subject: [PATCH 02/19] handler: more instances for Protected --- infra/default.nix | 2 + infra/handler/package.yaml | 1 + infra/handler/src/DeckGo/Handler.hs | 82 +++++++++++++++++------------ 3 files changed, 52 insertions(+), 33 deletions(-) diff --git a/infra/default.nix b/infra/default.nix index f5dbc3acf..abc268945 100644 --- a/infra/default.nix +++ b/infra/default.nix @@ -24,6 +24,8 @@ rec text = builtins.toJSON googleResp; }; + # TODO: don't use latest dynamodb (but pin version) + test = pkgs.runCommand "tests" { buildInputs = [ pkgs.jre pkgs.curl pkgs.netcat pkgs.awscli pkgs.haskellPackages.wai-app-static]; } '' diff --git a/infra/handler/package.yaml b/infra/handler/package.yaml index 25b6b95d2..320d99d50 100644 --- a/infra/handler/package.yaml +++ b/infra/handler/package.yaml @@ -15,6 +15,7 @@ dependencies: - random - servant - x509 + - word8 - pem #- servant-auth #- servant-auth-server diff --git a/infra/handler/src/DeckGo/Handler.hs b/infra/handler/src/DeckGo/Handler.hs index 28167336a..5e8c9dc66 100644 --- a/infra/handler/src/DeckGo/Handler.hs +++ b/infra/handler/src/DeckGo/Handler.hs @@ -18,13 +18,12 @@ import Control.Monad import Control.Monad.Except import Control.Lens hiding ((.=)) import Data.Proxy +import Data.Word8 (isSpace, toLower) import qualified Data.X509 as X509 import qualified Data.PEM as PEM +import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL --- import qualified Data.ByteString as BS import Servant.API -import qualified Crypto.JOSE.JWA.JWS as JOSE -import qualified Crypto.JOSE as JOSE import qualified Crypto.JWT as JWT import qualified Crypto.JOSE.JWK as JWK import qualified Data.Text as T @@ -37,15 +36,12 @@ import qualified Network.AWS as Aws import qualified Network.AWS.DynamoDB as DynamoDB import qualified Network.Wai as Wai import qualified Servant as Servant + +import qualified Servant.Server.Internal.RoutingApplication as Servant +import qualified Servant.Client.Core as Servant.Client import qualified Servant.Client.Core as Servant --- import qualified Servant.Auth as Servant import qualified System.Random as Random --- | Generate a key suitable for use with 'defaultConfig'. - -_sign :: JOSE.JWK -> JWT.ClaimsSet -> IO (Either JWT.JWTError JWT.SignedJWT) -_sign jwk cs = runExceptT $ JWT.signClaims jwk (JOSE.newJWSHeader ((), JOSE.RS256)) cs - newtype UserId = UserId { unUserId :: T.Text } deriving newtype (Aeson.FromJSON, Aeson.ToJSON, Show, Eq) @@ -54,8 +50,11 @@ newtype UnverifiedJWT = UnverifiedJWT JWT.SignedJWT -- TODO: MAKE SURE PATTERN MATCH FAILURES AREN'T PROPAGATED TO CLIENT!!! verifyUser :: UnverifiedJWT -> IO UserId verifyUser (UnverifiedJWT jwt) = do + -- TODO: Pull cert from google Just jwkmap <- Aeson.decodeFileStrict' "./cert" :: IO (Maybe (HMS.HashMap T.Text T.Text)) Just jwkct <- pure $ HMS.lookup "1" jwkmap + + -- TODO: get rid of 'error' pem <- case PEM.pemParseBS (T.encodeUtf8 jwkct) of Left e -> error $ show e Right [e] -> pure e @@ -64,7 +63,10 @@ verifyUser (UnverifiedJWT jwt) = do Left e -> error $ show e Right c -> pure c Right jwk <- runExceptT (JWK.fromX509Certificate cert) :: IO (Either JWT.JWTError JWT.JWK) + + -- TODO: fetch project id from config let config = JWT.defaultJWTValidationSettings (== "my-project-id") + runExceptT (JWT.verifyClaims config jwk jwt) >>= \case Right {} -> pure (UserId "") Left (e :: JWT.JWTError) -> error (show e) @@ -75,28 +77,46 @@ instance FromHttpApiData UnverifiedJWT where Left (e :: JWT.Error) -> Left $ T.pack $ show e Right jwt -> Right $ UnverifiedJWT jwt -instance Servant.RunClient m => Servant.HasClient m (Protected :> Get '[JSON] [WithId DeckId Deck]) where - type Client m (Protected :> Get '[JSON] [WithId DeckId Deck]) = T.Text -> Servant.Client m (Get '[JSON] [WithId DeckId Deck]) - clientWithRoute p Proxy req = \bs -> - -- TODO: header should be Authorization Bearer - Servant.clientWithRoute p (Proxy :: Proxy (Header "Authorization" T.Text :> Get '[JSON] [WithId DeckId Deck])) req (Just bs) - - hoistClientMonad Proxy Proxy hoist c = \bs -> hoist (c bs) - -instance Servant.HasServer (Protected :> Get '[JSON] [WithId DeckId Deck]) context where - type ServerT (Protected :> Get '[JSON] [WithId DeckId Deck]) m = UserId -> Servant.ServerT (Get '[JSON] [WithId DeckId Deck]) m - - route Proxy c sub = do - Servant.route (Proxy :: Proxy ( Header "Authorization" UnverifiedJWT :> Get '[JSON] [WithId DeckId Deck])) c (adapt <$> sub) +instance (Servant.HasClient m sub, Servant.RunClient m) => Servant.HasClient m (Protected :> sub) where + -- TODO: something better than just Text + type Client m (Protected :> sub) = T.Text -> Servant.Client m sub + clientWithRoute p1 Proxy req = \bs -> + Servant.clientWithRoute p1 (Proxy :: Proxy sub) (Servant.Client.addHeader "Authorization" ("Bearer " <> bs) req) + hoistClientMonad p1 Proxy hoist c = \bs -> + Servant.Client.hoistClientMonad p1 (Proxy :: Proxy sub) hoist (c bs) + +-- | Find and decode an 'Authorization' header from the request as JWT +decodeJWTHdr :: Wai.Request -> Either String UnverifiedJWT +decodeJWTHdr req = do + ah <- case lookup "Authorization" (Wai.requestHeaders req) of + Just x -> Right x + Nothing -> Left "No authorization header" + let (b, rest) = BS.break isSpace ah + guard (BS.map toLower b == "bearer") + tok <- case snd <$> BS.uncons rest of + Nothing -> Left "No token" + Just x -> Right x + case JWT.decodeCompact (BL.fromStrict tok) of + Left (e :: JWT.Error) -> Left $ show e <> ": " <> show rest + Right jwt -> Right (UnverifiedJWT jwt) + +runJWTAuth :: Wai.Request -> Servant.DelayedIO UserId +runJWTAuth req = case decodeJWTHdr req of + Left e -> error $ "bad auth: " <> e -- TODO: delayedFailFatal + Right ujwt -> liftIO $ verifyUser ujwt + +instance Servant.HasServer sub context => Servant.HasServer (Protected :> sub) context where + type ServerT (Protected :> sub) m = UserId -> Servant.ServerT sub m + + route Proxy c subserver = do + Servant.route (Proxy :: Proxy sub) + c (subserver `Servant.addAuthCheck` authCheck) where - adapt f = \case - Nothing -> error "NO SUCH FOOOO" - Just jwt -> do - uid <- liftIO $ verifyUser jwt - f uid + authCheck :: Servant.DelayedIO UserId + authCheck = Servant.withRequest $ runJWTAuth - - hoistServerWithContext = Servant.hoistServerWithContext + hoistServerWithContext Proxy p hoist s = \uid -> + Servant.hoistServerWithContext (Proxy :: Proxy sub) p hoist (s uid) ------------------------------------------------------------------------------ @@ -104,10 +124,6 @@ instance Servant.HasServer (Protected :> Get '[JSON] [WithId DeckId Deck]) cont ------------------------------------------------------------------------------ data Protected --- type Protected = Header "Bearer" JWT.SignedJWT - --- protect :: m b -> Maybe JWT.SignedJWT -> m b --- protect f _ = f data WithId id a = WithId id a deriving (Show, Eq) From 540ed53cfb3adefb8e20f6ca00f64fcbae3e5953 Mon Sep 17 00:00:00 2001 From: Nicolas Mattia Date: Fri, 29 Mar 2019 19:36:59 +0100 Subject: [PATCH 03/19] handler: read kid from JWT --- infra/default.nix | 2 +- infra/handler/src/DeckGo/Handler.hs | 4 +++- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/infra/default.nix b/infra/default.nix index abc268945..bb409d10e 100644 --- a/infra/default.nix +++ b/infra/default.nix @@ -16,7 +16,7 @@ rec publicKey = builtins.readFile ./public.cer; - googleResp = { "1" = publicKey ; }; + googleResp = { "key1" = publicKey ; }; apiDir = pkgs.writeTextFile { name = "google-resp"; diff --git a/infra/handler/src/DeckGo/Handler.hs b/infra/handler/src/DeckGo/Handler.hs index 5e8c9dc66..06f710fa6 100644 --- a/infra/handler/src/DeckGo/Handler.hs +++ b/infra/handler/src/DeckGo/Handler.hs @@ -14,6 +14,7 @@ module DeckGo.Handler where +import Data.Maybe (catMaybes) import Control.Monad import Control.Monad.Except import Control.Lens hiding ((.=)) @@ -52,7 +53,8 @@ verifyUser :: UnverifiedJWT -> IO UserId verifyUser (UnverifiedJWT jwt) = do -- TODO: Pull cert from google Just jwkmap <- Aeson.decodeFileStrict' "./cert" :: IO (Maybe (HMS.HashMap T.Text T.Text)) - Just jwkct <- pure $ HMS.lookup "1" jwkmap + let [JWT.HeaderParam () t] = catMaybes $ jwt ^.. JWT.signatures . JWT.header . JWT.kid + Just jwkct <- pure $ HMS.lookup t jwkmap -- TODO: get rid of 'error' pem <- case PEM.pemParseBS (T.encodeUtf8 jwkct) of From ec5ec1f20d91045fd1118a015b000fc7b581b87a Mon Sep 17 00:00:00 2001 From: Nicolas Mattia Date: Fri, 29 Mar 2019 21:20:22 +0100 Subject: [PATCH 04/19] handler: Clean up auth --- infra/default.nix | 30 +++++-- infra/handler/app/Handler.hs | 9 +- infra/handler/app/Server.hs | 23 +++-- infra/handler/app/Test.hs | 12 +-- infra/handler/package.yaml | 3 + infra/handler/src/DeckGo/Handler.hs | 133 ++++++++++++++++++---------- 6 files changed, 142 insertions(+), 68 deletions(-) diff --git a/infra/default.nix b/infra/default.nix index bb409d10e..559faddf3 100644 --- a/infra/default.nix +++ b/infra/default.nix @@ -26,15 +26,27 @@ rec # TODO: don't use latest dynamodb (but pin version) - test = pkgs.runCommand "tests" { buildInputs = [ pkgs.jre pkgs.curl pkgs.netcat pkgs.awscli pkgs.haskellPackages.wai-app-static]; } + test = pkgs.runCommand "tests" + { buildInputs = + [ pkgs.jre + pkgs.netcat + pkgs.awscli + pkgs.haskellPackages.wai-app-static + ]; + } '' - java -Djava.library.path=${dynamoJar}/DynamoDBLocal_lib -jar ${dynamoJar}/DynamoDBLocal.jar -sharedDb -port 8000 & + # Set up DynamoDB + java \ + -Djava.library.path=${dynamoJar}/DynamoDBLocal_lib \ + -jar ${dynamoJar}/DynamoDBLocal.jar \ + -sharedDb -port 8000 & while ! nc -z 127.0.0.1 8000; do echo waiting for DynamoDB sleep 1 done + export AWS_DEFAULT_REGION=us-east-1 export AWS_ACCESS_KEY_ID=dummy export AWS_SECRET_ACCESS_KEY=dummy @@ -45,7 +57,8 @@ rec AttributeName=DeckId,AttributeType=S \ --key-schema AttributeName=DeckId,KeyType=HASH \ --endpoint-url http://127.0.0.1:8000 \ - --provisioned-throughput ReadCapacityUnits=1,WriteCapacityUnits=1 + --provisioned-throughput ReadCapacityUnits=1,WriteCapacityUnits=1 \ + > /dev/null aws dynamodb create-table \ --table-name Slides \ @@ -53,28 +66,27 @@ rec AttributeName=SlideId,AttributeType=S \ --key-schema AttributeName=SlideId,KeyType=HASH \ --endpoint-url http://127.0.0.1:8000 \ - --provisioned-throughput ReadCapacityUnits=1,WriteCapacityUnits=1 + --provisioned-throughput ReadCapacityUnits=1,WriteCapacityUnits=1 \ + > /dev/null + # Start server with fs redirect for getProtocolByName NIX_REDIRECTS=/etc/protocols=${pkgs.iana-etc}/etc/protocols \ LD_PRELOAD="${pkgs.libredirect}/lib/libredirect.so" \ ${handler}/bin/server & - - cp ${pkgs.writeText "foo" (builtins.toJSON googleResp)} cert while ! nc -z 127.0.0.1 8080; do echo waiting for server sleep 1 done + # Set up mock server for Google public keys + cp ${pkgs.writeText "google-x509" (builtins.toJSON googleResp)} cert warp -d ${apiDir} -p 8081 & - while ! nc -z 127.0.0.1 8081; do echo waiting for warp sleep 1 done - curl localhost:8081/robot/v1/metadata/x509/securetoken@system.gserviceaccount.com - echo "Running tests" ${handler}/bin/test ${./token} diff --git a/infra/handler/app/Handler.hs b/infra/handler/app/Handler.hs index ced7cac14..601b30a2b 100644 --- a/infra/handler/app/Handler.hs +++ b/infra/handler/app/Handler.hs @@ -1,4 +1,7 @@ +{-# LANGUAGE OverloadedStrings #-} + import UnliftIO +import Control.Lens import qualified Network.AWS as Aws import qualified DeckGo.Handler import qualified Network.Wai.Handler.Lambda as Lambda @@ -13,4 +16,8 @@ main = do env <- Aws.newEnv Aws.Discover liftIO $ putStrLn "Booted!" - Lambda.run $ Cors.simpleCors $ DeckGo.Handler.application env + + -- TODO: from env + let projectId = DeckGo.Handler.FirebaseProjectId "my-project-id" + + Lambda.run $ Cors.simpleCors $ DeckGo.Handler.application (env ^. Aws.envManager) projectId env diff --git a/infra/handler/app/Server.hs b/infra/handler/app/Server.hs index 28df1de2b..5c1f6a10a 100644 --- a/infra/handler/app/Server.hs +++ b/infra/handler/app/Server.hs @@ -13,18 +13,31 @@ main = do hSetBuffering stdin LineBuffering hSetBuffering stdout LineBuffering mgr <- HTTPClient.newManager HTTPClient.tlsManagerSettings - { HTTPClient.managerModifyRequest = rerouteDynamoDB + { HTTPClient.managerModifyRequest = + pure . rerouteDynamoDB . rerouteGoogleApis } env <- Aws.newEnv Aws.Discover <&> Aws.envManager .~ mgr - Warp.run 8080 $ DeckGo.Handler.application env + let projectId = DeckGo.Handler.FirebaseProjectId "my-project-id" + Warp.run 8080 $ DeckGo.Handler.application mgr projectId env -rerouteDynamoDB :: HTTPClient.Request -> IO HTTPClient.Request +rerouteDynamoDB :: HTTPClient.Request -> HTTPClient.Request rerouteDynamoDB req = case HTTPClient.host req of "dynamodb.us-east-1.amazonaws.com" -> - pure req + req { HTTPClient.host = "127.0.0.1" , HTTPClient.port = 8000 , HTTPClient.secure = False } - _ -> pure req + _ -> req + +rerouteGoogleApis :: HTTPClient.Request -> HTTPClient.Request +rerouteGoogleApis req = + case HTTPClient.host req of + "www.googleapis.com" -> + req + { HTTPClient.host = "127.0.0.1" + , HTTPClient.port = 8081 + , HTTPClient.secure = False + } + _ -> req diff --git a/infra/handler/app/Test.hs b/infra/handler/app/Test.hs index f6fcbb929..bb7f8cb2e 100644 --- a/infra/handler/app/Test.hs +++ b/infra/handler/app/Test.hs @@ -39,7 +39,7 @@ main = do let newDeck = Deck { deckSlides = [ slideId ] } - runClientM (decksPut' deckId newDeck) clientEnv >>= \case + runClientM (decksPut' b deckId newDeck) clientEnv >>= \case Left err -> error $ "Expected updated deck, got error: " <> show err Right {} -> pure () @@ -48,7 +48,7 @@ main = do Right decks -> if decks == [WithId deckId newDeck] then pure () else (error $ "Expected updated decks, got: " <> show decks) - runClientM (decksGetDeckId' deckId) clientEnv >>= \case + runClientM (decksGetDeckId' b deckId) clientEnv >>= \case Left err -> error $ "Expected decks, got error: " <> show err Right deck -> if deck == (WithId deckId newDeck) then pure () else (error $ "Expected get deck, got: " <> show deck) @@ -83,7 +83,7 @@ main = do Right slides -> if slides == [] then pure () else (error $ "Expected no slides, got: " <> show slides) - runClientM (decksDelete' deckId) clientEnv >>= \case + runClientM (decksDelete' b deckId) clientEnv >>= \case Left err -> error $ "Expected deck delete, got error: " <> show err Right {} -> pure () @@ -94,10 +94,10 @@ main = do -- 'client' allows you to produce operations to query an API from a client. decksGet' :: T.Text -> ClientM [WithId DeckId Deck] -decksGetDeckId' :: DeckId -> ClientM (WithId DeckId Deck) +decksGetDeckId' :: T.Text -> DeckId -> ClientM (WithId DeckId Deck) decksPost' :: Deck -> ClientM (WithId DeckId Deck) -decksPut' :: DeckId -> Deck -> ClientM (WithId DeckId Deck) -decksDelete' :: DeckId -> ClientM () +decksPut' :: T.Text -> DeckId -> Deck -> ClientM (WithId DeckId Deck) +decksDelete' :: T.Text -> DeckId -> ClientM () slidesGet' :: ClientM [WithId SlideId Slide] slidesGetSlideId' :: SlideId -> ClientM (WithId SlideId Slide) slidesPost' :: Slide -> ClientM (WithId SlideId Slide) diff --git a/infra/handler/package.yaml b/infra/handler/package.yaml index 320d99d50..442ea1a5c 100644 --- a/infra/handler/package.yaml +++ b/infra/handler/package.yaml @@ -17,6 +17,9 @@ dependencies: - x509 - word8 - pem + - http-client + - http-client-tls + - http-conduit #- servant-auth #- servant-auth-server - servant-client-core diff --git a/infra/handler/src/DeckGo/Handler.hs b/infra/handler/src/DeckGo/Handler.hs index 06f710fa6..cd9cfa37d 100644 --- a/infra/handler/src/DeckGo/Handler.hs +++ b/infra/handler/src/DeckGo/Handler.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -14,47 +15,66 @@ module DeckGo.Handler where -import Data.Maybe (catMaybes) +-- TODO: double check what to return on 200 from DynamoDB + +import Control.Lens hiding ((.=)) import Control.Monad import Control.Monad.Except -import Control.Lens hiding ((.=)) +import Data.Aeson ((.=), (.:), (.!=), (.:?)) import Data.Proxy -import Data.Word8 (isSpace, toLower) -import qualified Data.X509 as X509 -import qualified Data.PEM as PEM -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BL +import Data.Word8 (isSpace, toLower) +import Servant (Context ((:.))) import Servant.API -import qualified Crypto.JWT as JWT +import UnliftIO import qualified Crypto.JOSE.JWK as JWK +import qualified Crypto.JWT as JWT +import qualified Data.Aeson as Aeson +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +import qualified Data.HashMap.Strict as HMS +import qualified Data.PEM as PEM import qualified Data.Text as T import qualified Data.Text.Encoding as T -import qualified Data.HashMap.Strict as HMS -import UnliftIO -import Data.Aeson ((.=), (.:), (.!=), (.:?)) -import qualified Data.Aeson as Aeson +import qualified Data.X509 as X509 import qualified Network.AWS as Aws import qualified Network.AWS.DynamoDB as DynamoDB +import qualified Network.HTTP.Client as HTTP +import qualified Network.HTTP.Simple as HTTP import qualified Network.Wai as Wai import qualified Servant as Servant - -import qualified Servant.Server.Internal.RoutingApplication as Servant -import qualified Servant.Client.Core as Servant.Client import qualified Servant.Client.Core as Servant +import qualified Servant.Client.Core as Servant.Client +import qualified Servant.Server.Internal.RoutingApplication as Servant import qualified System.Random as Random +newtype FirebaseProjectId = FirebaseProjectId { unFirebaseProjectId :: T.Text } +data ServerContext = ServerContext { firebaseProjectId :: FirebaseProjectId } + newtype UserId = UserId { unUserId :: T.Text } deriving newtype (Aeson.FromJSON, Aeson.ToJSON, Show, Eq) newtype UnverifiedJWT = UnverifiedJWT JWT.SignedJWT -- TODO: MAKE SURE PATTERN MATCH FAILURES AREN'T PROPAGATED TO CLIENT!!! -verifyUser :: UnverifiedJWT -> IO UserId -verifyUser (UnverifiedJWT jwt) = do - -- TODO: Pull cert from google - Just jwkmap <- Aeson.decodeFileStrict' "./cert" :: IO (Maybe (HMS.HashMap T.Text T.Text)) - let [JWT.HeaderParam () t] = catMaybes $ jwt ^.. JWT.signatures . JWT.header . JWT.kid - Just jwkct <- pure $ HMS.lookup t jwkmap +verifyUser :: HTTP.Manager -> FirebaseProjectId -> UnverifiedJWT -> IO UserId +verifyUser mgr (FirebaseProjectId projectId) (UnverifiedJWT jwt) = do + + -- TODO: proper error handling here + let req = + HTTP.setRequestSecure True . + HTTP.setRequestHost "www.googleapis.com" . + HTTP.setRequestPath "/robot/v1/metadata/x509/securetoken@system.gserviceaccount.com" . + HTTP.setRequestManager mgr $ + HTTP.defaultRequest + jwkmap <- HTTP.getResponseBody <$> HTTP.httpJSON req + + t <- case jwt ^.. JWT.signatures . JWT.header . JWT.kid of + [Just (JWT.HeaderParam () t)] -> pure t + xs -> error $ "Expected exactly one signature with 'kid', got: " <> show xs + + jwkct <- case HMS.lookup t jwkmap of + Nothing -> error $ "Could not find key " <> show t <> " in response" + Just ct -> pure ct -- TODO: get rid of 'error' pem <- case PEM.pemParseBS (T.encodeUtf8 jwkct) of @@ -64,12 +84,16 @@ verifyUser (UnverifiedJWT jwt) = do cert <- case X509.decodeSignedCertificate (PEM.pemContent pem) of Left e -> error $ show e Right c -> pure c - Right jwk <- runExceptT (JWK.fromX509Certificate cert) :: IO (Either JWT.JWTError JWT.JWK) + jwk <- runExceptT (JWK.fromX509Certificate cert) >>= \case + Left (e :: JWT.JWTError) -> error $ show e + Right jwk -> pure jwk - -- TODO: fetch project id from config - let config = JWT.defaultJWTValidationSettings (== "my-project-id") + let config = JWT.defaultJWTValidationSettings $ \sou -> + Just projectId == sou ^? JWT.string runExceptT (JWT.verifyClaims config jwk jwt) >>= \case + -- TODO: get user from claims + -- TODO: check all the claims Right {} -> pure (UserId "") Left (e :: JWT.JWTError) -> error (show e) @@ -79,11 +103,15 @@ instance FromHttpApiData UnverifiedJWT where Left (e :: JWT.Error) -> Left $ T.pack $ show e Right jwt -> Right $ UnverifiedJWT jwt -instance (Servant.HasClient m sub, Servant.RunClient m) => Servant.HasClient m (Protected :> sub) where +instance + ( Servant.HasClient m sub + , Servant.RunClient m ) => Servant.HasClient m (Protected :> sub) where -- TODO: something better than just Text type Client m (Protected :> sub) = T.Text -> Servant.Client m sub clientWithRoute p1 Proxy req = \bs -> - Servant.clientWithRoute p1 (Proxy :: Proxy sub) (Servant.Client.addHeader "Authorization" ("Bearer " <> bs) req) + Servant.clientWithRoute + p1 (Proxy :: Proxy sub) + (Servant.Client.addHeader "Authorization" ("Bearer " <> bs) req) hoistClientMonad p1 Proxy hoist c = \bs -> Servant.Client.hoistClientMonad p1 (Proxy :: Proxy sub) hoist (c bs) @@ -102,12 +130,16 @@ decodeJWTHdr req = do Left (e :: JWT.Error) -> Left $ show e <> ": " <> show rest Right jwt -> Right (UnverifiedJWT jwt) -runJWTAuth :: Wai.Request -> Servant.DelayedIO UserId -runJWTAuth req = case decodeJWTHdr req of +runJWTAuth :: HTTP.Manager -> FirebaseProjectId -> Wai.Request -> Servant.DelayedIO UserId +runJWTAuth mgr projectId req = case decodeJWTHdr req of Left e -> error $ "bad auth: " <> e -- TODO: delayedFailFatal - Right ujwt -> liftIO $ verifyUser ujwt + Right ujwt -> liftIO $ verifyUser mgr projectId ujwt -instance Servant.HasServer sub context => Servant.HasServer (Protected :> sub) context where +instance + ( Servant.HasContextEntry context FirebaseProjectId + , Servant.HasContextEntry context HTTP.Manager + , Servant.HasServer sub context + ) => Servant.HasServer (Protected :> sub) context where type ServerT (Protected :> sub) m = UserId -> Servant.ServerT sub m route Proxy c subserver = do @@ -116,11 +148,11 @@ instance Servant.HasServer sub context => Servant.HasServer (Protected :> sub) c where authCheck :: Servant.DelayedIO UserId authCheck = Servant.withRequest $ runJWTAuth + (Servant.getContextEntry c) (Servant.getContextEntry c) hoistServerWithContext Proxy p hoist s = \uid -> Servant.hoistServerWithContext (Proxy :: Proxy sub) p hoist (s uid) - ------------------------------------------------------------------------------ -- API ------------------------------------------------------------------------------ @@ -205,10 +237,14 @@ type API = type DecksAPI = Protected :> Get '[JSON] [WithId DeckId Deck] :<|> - Capture "deck_id" DeckId :> Get '[JSON] (WithId DeckId Deck) :<|> + Protected :> + Capture "deck_id" DeckId :> + Get '[JSON] (WithId DeckId Deck) :<|> ReqBody '[JSON] Deck :> Post '[JSON] (WithId DeckId Deck) :<|> - Capture "deck_id" DeckId :> ReqBody '[JSON] Deck :> Put '[JSON] (WithId DeckId Deck) :<|> - Capture "deck_id" DeckId :> Delete '[JSON] () + Protected :> + Capture "deck_id" DeckId :> + ReqBody '[JSON] Deck :> Put '[JSON] (WithId DeckId Deck) :<|> + Protected :> Capture "deck_id" DeckId :> Delete '[JSON] () type SlidesAPI = Get '[JSON] [WithId SlideId Slide] :<|> @@ -224,8 +260,12 @@ api = Proxy -- SERVER ------------------------------------------------------------------------------ -application :: Aws.Env -> Wai.Application -application env = Servant.serve api (server env) +application :: HTTP.Manager -> FirebaseProjectId -> Aws.Env -> Wai.Application +application mgr projectId env = + Servant.serveWithContext + api + (mgr :. projectId :. Servant.EmptyContext) + (server env) server :: Aws.Env -> Servant.Server API server env = serveDecks :<|> serveSlides @@ -244,8 +284,7 @@ server env = serveDecks :<|> serveSlides slidesDelete env decksGet :: Aws.Env -> UserId -> Servant.Handler [WithId DeckId Deck] -decksGet env uid = do - liftIO $ print uid +decksGet env _uid = do res <- runAWS env $ Aws.send $ DynamoDB.scan "Decks" case res of Right scanResponse -> @@ -258,8 +297,8 @@ decksGet env uid = do liftIO $ print e Servant.throwError Servant.err500 -decksGetDeckId :: Aws.Env -> DeckId -> Servant.Handler (WithId DeckId Deck) -decksGetDeckId env deckId = do +decksGetDeckId :: Aws.Env -> UserId -> DeckId -> Servant.Handler (WithId DeckId Deck) +decksGetDeckId env _ deckId = do res <- runAWS env $ Aws.send $ DynamoDB.getItem "Decks" & DynamoDB.giKey .~ HMS.singleton "DeckId" (deckIdToAttributeValue deckId) case res of @@ -300,8 +339,8 @@ decksPost env deck = do pure $ WithId deckId deck -decksPut :: Aws.Env -> DeckId -> Deck -> Servant.Handler (WithId DeckId Deck) -decksPut env deckId deck = do +decksPut :: Aws.Env -> UserId -> DeckId -> Deck -> Servant.Handler (WithId DeckId Deck) +decksPut env _ deckId deck = do res <- runAWS env $ Aws.send $ DynamoDB.updateItem "Decks" & DynamoDB.uiUpdateExpression .~ Just "SET DeckSlides = :s" & @@ -318,8 +357,8 @@ decksPut env deckId deck = do pure $ WithId deckId deck -decksDelete :: Aws.Env -> DeckId -> Servant.Handler () -decksDelete env deckId = do +decksDelete :: Aws.Env -> UserId -> DeckId -> Servant.Handler () +decksDelete env _ deckId = do res <- runAWS env $ Aws.send $ DynamoDB.deleteItem "Decks" & DynamoDB.diKey .~ HMS.singleton "DeckId" @@ -404,11 +443,11 @@ slidesPut env slideId slide = do "SET SlideContent = :c, SlideTemplate = :t, SlideAttributes = :a" & DynamoDB.uiExpressionAttributeValues .~ slideToItem' slide & DynamoDB.uiReturnValues .~ Just DynamoDB.UpdatedNew & - DynamoDB.uiKey .~ HMS.singleton "SlideId" + DynamoDB.uiKey .~ HMS.singleton "SlideId" (slideIdToAttributeValue slideId) case res of - Right x -> liftIO $ print x + Right {} -> pure () Left e -> do liftIO $ print e Servant.throwError Servant.err500 @@ -423,7 +462,7 @@ slidesDelete env slideId = do (slideIdToAttributeValue slideId) case res of - Right x -> liftIO $ print x + Right {} -> pure () Left e -> do liftIO $ print e Servant.throwError Servant.err500 From 39ceca6218a7bc4986f1e5ca3907cb8b19ff6013 Mon Sep 17 00:00:00 2001 From: Nicolas Mattia Date: Fri, 29 Mar 2019 22:36:09 +0100 Subject: [PATCH 05/19] handler: remove newline in token --- infra/token | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/infra/token b/infra/token index 7f2fddd0d..da486e823 100644 --- a/infra/token +++ b/infra/token @@ -1 +1 @@ -eyJhbGciOiJSUzI1NiIsImtpZCI6ImtleTEifQ.eyJleHAiOjE5MDMxMTk2MzAsInN1YiI6InRoZS11aWQiLCJuYW1lIjoiSm9obiBEb2UiLCJhZG1pbiI6dHJ1ZSwiaXNzIjoiaHR0cHM6Ly9zZWN1cmV0b2tlbi5nb29nbGUuY29tL215LXByb2plY3QtaWQiLCJpYXQiOjE1MTYyMzkwMjIsImF1ZCI6Im15LXByb2plY3QtaWQiLCJhdXRoX3RpbWUiOjE1NTM4MDQ1NzN9.IwJ_qdtKwnxukFX8ylNZyUyAaN_ODzUf841LLsmTd22qM6kCSRHDY5JJdIN3ZDajH-Rk8O2kCzmRZ2HwfhBtpSyn7E8dKt0Ajw8VtW8d_hmj5LWv0doUiiEhtRtADA9AFJYmv_jFmNoL6cX6HqSQr2ZD53GC0WSA46A0lD3K4KE +eyJhbGciOiJSUzI1NiIsImtpZCI6ImtleTEifQ.eyJleHAiOjE5MDMxMTk2MzAsInN1YiI6InRoZS11aWQiLCJuYW1lIjoiSm9obiBEb2UiLCJhZG1pbiI6dHJ1ZSwiaXNzIjoiaHR0cHM6Ly9zZWN1cmV0b2tlbi5nb29nbGUuY29tL215LXByb2plY3QtaWQiLCJpYXQiOjE1MTYyMzkwMjIsImF1ZCI6Im15LXByb2plY3QtaWQiLCJhdXRoX3RpbWUiOjE1NTM4MDQ1NzN9.IwJ_qdtKwnxukFX8ylNZyUyAaN_ODzUf841LLsmTd22qM6kCSRHDY5JJdIN3ZDajH-Rk8O2kCzmRZ2HwfhBtpSyn7E8dKt0Ajw8VtW8d_hmj5LWv0doUiiEhtRtADA9AFJYmv_jFmNoL6cX6HqSQr2ZD53GC0WSA46A0lD3K4KE \ No newline at end of file From 18e610a654ca7dd250804fbf53fda70c9d11bef4 Mon Sep 17 00:00:00 2001 From: Nicolas Mattia Date: Fri, 29 Mar 2019 23:33:18 +0100 Subject: [PATCH 06/19] handler: check claims --- infra/handler/package.yaml | 3 +-- infra/handler/src/DeckGo/Handler.hs | 21 +++++++++++++++++---- 2 files changed, 18 insertions(+), 6 deletions(-) diff --git a/infra/handler/package.yaml b/infra/handler/package.yaml index 442ea1a5c..31c90722a 100644 --- a/infra/handler/package.yaml +++ b/infra/handler/package.yaml @@ -20,8 +20,7 @@ dependencies: - http-client - http-client-tls - http-conduit - #- servant-auth - #- servant-auth-server + - network-uri - servant-client-core - servant-server - text diff --git a/infra/handler/src/DeckGo/Handler.hs b/infra/handler/src/DeckGo/Handler.hs index cd9cfa37d..da42c039d 100644 --- a/infra/handler/src/DeckGo/Handler.hs +++ b/infra/handler/src/DeckGo/Handler.hs @@ -27,6 +27,7 @@ import Servant (Context ((:.))) import Servant.API import UnliftIO import qualified Crypto.JOSE.JWK as JWK +import qualified Network.URI as URI import qualified Crypto.JWT as JWT import qualified Data.Aeson as Aeson import qualified Data.ByteString as BS @@ -81,20 +82,32 @@ verifyUser mgr (FirebaseProjectId projectId) (UnverifiedJWT jwt) = do Left e -> error $ show e Right [e] -> pure e Right xs -> error $ show xs + cert <- case X509.decodeSignedCertificate (PEM.pemContent pem) of Left e -> error $ show e Right c -> pure c + jwk <- runExceptT (JWK.fromX509Certificate cert) >>= \case Left (e :: JWT.JWTError) -> error $ show e Right jwk -> pure jwk - let config = JWT.defaultJWTValidationSettings $ \sou -> - Just projectId == sou ^? JWT.string + issUri <- case URI.parseURI $ "https://securetoken.google.com/" <> T.unpack projectId of + Just issUri -> pure issUri + Nothing -> error $ "Could not use project ID in URI" + let config = + JWT.defaultJWTValidationSettings + (\sou -> Just projectId == sou ^? JWT.string) & -- aud + JWT.issuerPredicate .~ (\sou -> Just issUri == sou ^? JWT.uri) -- iss runExceptT (JWT.verifyClaims config jwk jwt) >>= \case -- TODO: get user from claims -- TODO: check all the claims - Right {} -> pure (UserId "") + Right cs -> do + case cs ^. JWT.claimSub of + Nothing -> error "Could not get a subject from claim set" + Just sou -> case sou ^? JWT.string of + Nothing -> error "Expected subject to be string" + Just u -> pure (UserId u) Left (e :: JWT.JWTError) -> error (show e) instance FromHttpApiData UnverifiedJWT where @@ -133,7 +146,7 @@ decodeJWTHdr req = do runJWTAuth :: HTTP.Manager -> FirebaseProjectId -> Wai.Request -> Servant.DelayedIO UserId runJWTAuth mgr projectId req = case decodeJWTHdr req of Left e -> error $ "bad auth: " <> e -- TODO: delayedFailFatal - Right ujwt -> liftIO $ verifyUser mgr projectId ujwt + Right ujwt -> liftIO $ verifyUser mgr projectId ujwt instance ( Servant.HasContextEntry context FirebaseProjectId From 3790712796282289983562c129442c24331863ca Mon Sep 17 00:00:00 2001 From: Nicolas Mattia Date: Sat, 30 Mar 2019 00:41:52 +0100 Subject: [PATCH 07/19] handler: extract firebase-login --- infra/firebase-login/default.nix | 5 + infra/firebase-login/nix/default.nix | 17 ++ infra/firebase-login/nix/packages.nix | 19 +++ infra/firebase-login/nix/sources.json | 37 +++++ infra/firebase-login/nix/sources.nix | 29 ++++ infra/firebase-login/package.yaml | 31 ++++ infra/firebase-login/script/test | 4 + infra/firebase-login/script/update | 6 + infra/firebase-login/script/upload | 13 ++ infra/firebase-login/shell.nix | 5 + .../src/Servant/Auth/Firebase.hs | 155 ++++++++++++++++++ infra/handler/app/Handler.hs | 3 +- infra/handler/app/Server.hs | 3 +- infra/handler/package.yaml | 19 ++- infra/handler/src/DeckGo/Handler.hs | 146 +---------------- infra/nix/default.nix | 1 + 16 files changed, 345 insertions(+), 148 deletions(-) create mode 100644 infra/firebase-login/default.nix create mode 100644 infra/firebase-login/nix/default.nix create mode 100644 infra/firebase-login/nix/packages.nix create mode 100644 infra/firebase-login/nix/sources.json create mode 100644 infra/firebase-login/nix/sources.nix create mode 100644 infra/firebase-login/package.yaml create mode 100755 infra/firebase-login/script/test create mode 100755 infra/firebase-login/script/update create mode 100755 infra/firebase-login/script/upload create mode 100644 infra/firebase-login/shell.nix create mode 100644 infra/firebase-login/src/Servant/Auth/Firebase.hs diff --git a/infra/firebase-login/default.nix b/infra/firebase-login/default.nix new file mode 100644 index 000000000..98886d29f --- /dev/null +++ b/infra/firebase-login/default.nix @@ -0,0 +1,5 @@ +# TODO: port tests +# TODO: fix sources +# TODO: drop nix/packages +with { pkgs = import ./nix {}; }; +pkgs.callPackage ./nix/packages.nix {} diff --git a/infra/firebase-login/nix/default.nix b/infra/firebase-login/nix/default.nix new file mode 100644 index 000000000..9e5aa9365 --- /dev/null +++ b/infra/firebase-login/nix/default.nix @@ -0,0 +1,17 @@ +{ sources ? import ./sources.nix }: +with + { overlay = _: pkgs: rec + { inherit (import sources.niv {}) niv; + haskellPackages = pkgs.haskellPackages.override + { overrides = _: super: + { jose = super.callCabal2nix "jose" sources.hs-jose {}; }; + }; + + packages = import ./packages.nix + { inherit (pkgs) haskell lib ; + inherit haskellPackages; + }; + }; + }; +import sources.nixpkgs + { overlays = [ overlay ] ; config = {}; } diff --git a/infra/firebase-login/nix/packages.nix b/infra/firebase-login/nix/packages.nix new file mode 100644 index 000000000..90a21ea56 --- /dev/null +++ b/infra/firebase-login/nix/packages.nix @@ -0,0 +1,19 @@ +{ haskell +, haskellPackages +, lib +, runCommand +, writeText +, zip +}: +rec +{ firebase-login-sdist = haskell.lib.sdistTarball firebase-login; + firebase-login = haskellPackages.callCabal2nix "firebase-login" firebase-login-source {}; + firebase-login-source = lib.sourceByRegex ../. + [ "^package.yaml$" + "^src.*" + "^examples.*" + "^README.md$" + "^LICENSE$" + ]; + firebase-login-version-file = writeText "version" firebase-login.version; +} diff --git a/infra/firebase-login/nix/sources.json b/infra/firebase-login/nix/sources.json new file mode 100644 index 000000000..6250130f0 --- /dev/null +++ b/infra/firebase-login/nix/sources.json @@ -0,0 +1,37 @@ +{ + "nixpkgs": { + "url": "https://github.com/NixOS/nixpkgs-channels/archive/395a543f3605ea7c17797ad33fda0c251b802978.tar.gz", + "owner": "NixOS", + "branch": "nixos-18.09", + "url_template": "https://github.com///archive/.tar.gz", + "repo": "nixpkgs-channels", + "type": "tarball", + "sha256": "0az7333nr9fax6885kj7s61c0hs6wblj7a2y78k4pq0jnhjxqzzg", + "description": "Nixpkgs/NixOS branches that track the Nixpkgs/NixOS channels", + "rev": "395a543f3605ea7c17797ad33fda0c251b802978" + }, + "hs-jose": { + "homepage": "http://hackage.haskell.org/package/jose", + "url": "https://github.com/frasertweedale/hs-jose/archive/71274bf64c0600c1d877152173a08a5bff7adf4d.tar.gz", + "owner": "frasertweedale", + "branch": "master", + "url_template": "https://github.com///archive/.tar.gz", + "repo": "hs-jose", + "type": "tarball", + "sha256": "0ah189vika1s0jk8f17mn77gilkw24vbs6xlggxw1qj926i6c4pk", + "description": "Haskell JOSE and JWT library", + "rev": "71274bf64c0600c1d877152173a08a5bff7adf4d" + }, + "niv": { + "homepage": "https://github.com/nmattia/niv", + "url": "https://github.com/nmattia/niv/archive/f57c85d05e6c2dd359f901d936f896e4f117d3e6.tar.gz", + "owner": "nmattia", + "branch": "master", + "url_template": "https://github.com///archive/.tar.gz", + "repo": "niv", + "type": "tarball", + "sha256": "0fbmbc73qgd4f07pag18zkdh65wxv406jm3rdrrfkk85l1inscg3", + "description": "Easy dependency management for Nix projects", + "rev": "f57c85d05e6c2dd359f901d936f896e4f117d3e6" + } +} \ No newline at end of file diff --git a/infra/firebase-login/nix/sources.nix b/infra/firebase-login/nix/sources.nix new file mode 100644 index 000000000..c0941e9cd --- /dev/null +++ b/infra/firebase-login/nix/sources.nix @@ -0,0 +1,29 @@ +# A record, from name to path, of the third-party packages +with +{ + sources = builtins.fromJSON (builtins.readFile ./sources.json); + + # fetchTarball version that is compatible between all the sources of Nix + fetchTarball = + { url, sha256 }: + if builtins.lessThan builtins.nixVersion "1.12" then + builtins.fetchTarball { inherit url; } + else + builtins.fetchTarball { inherit url sha256; }; + mapAttrs = builtins.mapAttrs or + (f: set: with builtins; + listToAttrs (map (attr: { name = attr; value = f attr set.${attr}; }) (attrNames set))); +}; + +# NOTE: spec must _not_ have an "outPath" attribute +mapAttrs (_: spec: + if builtins.hasAttr "outPath" spec + then abort + "The values in sources.json should not have an 'outPath' attribute" + else + if builtins.hasAttr "url" spec && builtins.hasAttr "sha256" spec + then + spec // + { outPath = fetchTarball { inherit (spec) url sha256; } ; } + else spec + ) sources diff --git a/infra/firebase-login/package.yaml b/infra/firebase-login/package.yaml new file mode 100644 index 000000000..b10e906f2 --- /dev/null +++ b/infra/firebase-login/package.yaml @@ -0,0 +1,31 @@ +name: firebase-login +maintainer: Nicolas Mattia +copyright: (c) 2019 David Dal Busco and Nicolas Mattia +license: MIT + +dependencies: + - aeson + - base + - bytestring + - http-client + - http-client-tls + - http-conduit + - jose >= 0.8.0.0 # For fromX509Certificate + - lens + - mtl + - network-uri + - pem + - servant + - servant-client-core + - servant-server + - text + - unordered-containers + - wai + - word8 + - x509 + +ghc-options: + - -Wall + +library: + source-dirs: src diff --git a/infra/firebase-login/script/test b/infra/firebase-login/script/test new file mode 100755 index 000000000..8a3c975f8 --- /dev/null +++ b/infra/firebase-login/script/test @@ -0,0 +1,4 @@ +#!/usr/bin/env bash +# vim: filetype=sh + +nix-build --no-link diff --git a/infra/firebase-login/script/update b/infra/firebase-login/script/update new file mode 100755 index 000000000..793f96530 --- /dev/null +++ b/infra/firebase-login/script/update @@ -0,0 +1,6 @@ +#!/usr/bin/env nix-shell +#!nix-shell -I nixpkgs=./nix +#!nix-shell -i bash -p niv nix --pure +# vim: filetype=sh + +niv update diff --git a/infra/firebase-login/script/upload b/infra/firebase-login/script/upload new file mode 100755 index 000000000..be694269d --- /dev/null +++ b/infra/firebase-login/script/upload @@ -0,0 +1,13 @@ +#!/usr/bin/env nix-shell +#!nix-shell -I nixpkgs=./nix +#!nix-shell -i bash -p cabal-install -p nix -p curl --pure +# vim: filetype=sh + +set -euo pipefail + +sdistVersion=$(cat $(nix-build -A firebase-login-version-file)) +sdistTarball=$(nix-build -A firebase-login-sdist)/firebase-login-$sdistVersion.tar.gz + +echo "Tarball: $sdistTarball" + +cabal upload "$@" $sdistTarball diff --git a/infra/firebase-login/shell.nix b/infra/firebase-login/shell.nix new file mode 100644 index 000000000..a9f1b11cc --- /dev/null +++ b/infra/firebase-login/shell.nix @@ -0,0 +1,5 @@ +with { pkgs = import ./nix {}; }; +pkgs.haskellPackages.developPackage + { root = ./.; + modifier = drv: drv // { buildInputs = drv.buildInputs ++ [ pkgs.cabal-install ]; } ; + } diff --git a/infra/firebase-login/src/Servant/Auth/Firebase.hs b/infra/firebase-login/src/Servant/Auth/Firebase.hs new file mode 100644 index 000000000..f8ca8b035 --- /dev/null +++ b/infra/firebase-login/src/Servant/Auth/Firebase.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + +module Servant.Auth.Firebase where + +import Control.Lens hiding ((.=)) +import Control.Monad +import Control.Monad.Except +import Data.Proxy +import Data.Word8 (isSpace, toLower) +import Servant.API +import qualified Crypto.JOSE.JWK as JWK +import qualified Network.URI as URI +import qualified Crypto.JWT as JWT +import qualified Data.Aeson as Aeson +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +import qualified Data.HashMap.Strict as HMS +import qualified Data.PEM as PEM +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.X509 as X509 +import qualified Network.HTTP.Client as HTTP +import qualified Network.HTTP.Simple as HTTP +import qualified Network.Wai as Wai +import qualified Servant as Servant +import qualified Servant.Client.Core as Servant +import qualified Servant.Client.Core as Servant.Client +import qualified Servant.Server.Internal.RoutingApplication as Servant + +data Protected + +newtype ProjectId = ProjectId { unFirebaseProjectId :: T.Text } +data ServerContext = ServerContext { firebaseProjectId :: ProjectId } + +newtype UserId = UserId { unUserId :: T.Text } + deriving newtype (Aeson.FromJSON, Aeson.ToJSON, Show, Eq) + +newtype UnverifiedJWT = UnverifiedJWT JWT.SignedJWT + +-- TODO: MAKE SURE PATTERN MATCH FAILURES AREN'T PROPAGATED TO CLIENT!!! +verifyUser :: HTTP.Manager -> ProjectId -> UnverifiedJWT -> IO UserId +verifyUser mgr (ProjectId projectId) (UnverifiedJWT jwt) = do + + -- TODO: proper error handling here + let req = + HTTP.setRequestSecure True . + HTTP.setRequestHost "www.googleapis.com" . + HTTP.setRequestPath "/robot/v1/metadata/x509/securetoken@system.gserviceaccount.com" . + HTTP.setRequestManager mgr $ + HTTP.defaultRequest + jwkmap <- HTTP.getResponseBody <$> HTTP.httpJSON req + + t <- case jwt ^.. JWT.signatures . JWT.header . JWT.kid of + [Just (JWT.HeaderParam () t)] -> pure t + xs -> error $ "Expected exactly one signature with 'kid', got: " <> show xs + + jwkct <- case HMS.lookup t jwkmap of + Nothing -> error $ "Could not find key " <> show t <> " in response" + Just ct -> pure ct + + -- TODO: get rid of 'error' + pem <- case PEM.pemParseBS (T.encodeUtf8 jwkct) of + Left e -> error $ show e + Right [e] -> pure e + Right xs -> error $ show xs + + cert <- case X509.decodeSignedCertificate (PEM.pemContent pem) of + Left e -> error $ show e + Right c -> pure c + + jwk <- runExceptT (JWK.fromX509Certificate cert) >>= \case + Left (e :: JWT.JWTError) -> error $ show e + Right jwk -> pure jwk + + issUri <- case URI.parseURI $ "https://securetoken.google.com/" <> T.unpack projectId of + Just issUri -> pure issUri + Nothing -> error $ "Could not use project ID in URI" + + let config = + JWT.defaultJWTValidationSettings + (\sou -> Just projectId == sou ^? JWT.string) & -- aud + JWT.issuerPredicate .~ (\sou -> Just issUri == sou ^? JWT.uri) -- iss + runExceptT (JWT.verifyClaims config jwk jwt) >>= \case + Right cs -> do + case cs ^. JWT.claimSub of + Nothing -> error "Could not get a subject from claim set" + Just sou -> case sou ^? JWT.string of + Nothing -> error "Expected subject to be string" + Just u -> pure (UserId u) + Left (e :: JWT.JWTError) -> error (show e) + +instance FromHttpApiData UnverifiedJWT where + parseUrlPiece = const $ Left "No support for JWT" + parseHeader bs = case JWT.decodeCompact (BL.fromStrict bs) of + Left (e :: JWT.Error) -> Left $ T.pack $ show e + Right jwt -> Right $ UnverifiedJWT jwt + +instance + ( Servant.HasClient m sub + , Servant.RunClient m ) => Servant.HasClient m (Protected :> sub) where + -- TODO: something better than just Text + type Client m (Protected :> sub) = T.Text -> Servant.Client m sub + clientWithRoute p1 Proxy req = \bs -> + Servant.clientWithRoute + p1 (Proxy :: Proxy sub) + (Servant.Client.addHeader "Authorization" ("Bearer " <> bs) req) + hoistClientMonad p1 Proxy hoist c = \bs -> + Servant.Client.hoistClientMonad p1 (Proxy :: Proxy sub) hoist (c bs) + +-- | Find and decode an 'Authorization' header from the request as JWT +decodeJWTHdr :: Wai.Request -> Either String UnverifiedJWT +decodeJWTHdr req = do + ah <- case lookup "Authorization" (Wai.requestHeaders req) of + Just x -> Right x + Nothing -> Left "No authorization header" + let (b, rest) = BS.break isSpace ah + guard (BS.map toLower b == "bearer") + tok <- case snd <$> BS.uncons rest of + Nothing -> Left "No token" + Just x -> Right x + case JWT.decodeCompact (BL.fromStrict tok) of + Left (e :: JWT.Error) -> Left $ show e <> ": " <> show rest + Right jwt -> Right (UnverifiedJWT jwt) + +runJWTAuth :: HTTP.Manager -> ProjectId -> Wai.Request -> Servant.DelayedIO UserId +runJWTAuth mgr projectId req = case decodeJWTHdr req of + Left e -> error $ "bad auth: " <> e -- TODO: delayedFailFatal + Right ujwt -> liftIO $ verifyUser mgr projectId ujwt + +instance + ( Servant.HasContextEntry context ProjectId + , Servant.HasContextEntry context HTTP.Manager + , Servant.HasServer sub context + ) => Servant.HasServer (Protected :> sub) context where + type ServerT (Protected :> sub) m = UserId -> Servant.ServerT sub m + + route Proxy c subserver = do + Servant.route (Proxy :: Proxy sub) + c (subserver `Servant.addAuthCheck` authCheck) + where + authCheck :: Servant.DelayedIO UserId + authCheck = Servant.withRequest $ runJWTAuth + (Servant.getContextEntry c) (Servant.getContextEntry c) + + hoistServerWithContext Proxy p hoist s = \uid -> + Servant.hoistServerWithContext (Proxy :: Proxy sub) p hoist (s uid) diff --git a/infra/handler/app/Handler.hs b/infra/handler/app/Handler.hs index 601b30a2b..9de6e86ed 100644 --- a/infra/handler/app/Handler.hs +++ b/infra/handler/app/Handler.hs @@ -2,6 +2,7 @@ import UnliftIO import Control.Lens +import Servant.Auth.Firebase (ProjectId(..)) import qualified Network.AWS as Aws import qualified DeckGo.Handler import qualified Network.Wai.Handler.Lambda as Lambda @@ -18,6 +19,6 @@ main = do liftIO $ putStrLn "Booted!" -- TODO: from env - let projectId = DeckGo.Handler.FirebaseProjectId "my-project-id" + let projectId = ProjectId "my-project-id" Lambda.run $ Cors.simpleCors $ DeckGo.Handler.application (env ^. Aws.envManager) projectId env diff --git a/infra/handler/app/Server.hs b/infra/handler/app/Server.hs index 5c1f6a10a..9ab453a6b 100644 --- a/infra/handler/app/Server.hs +++ b/infra/handler/app/Server.hs @@ -2,6 +2,7 @@ import UnliftIO import Control.Lens +import Servant.Auth.Firebase (ProjectId(..)) import qualified Network.HTTP.Client as HTTPClient import qualified Network.HTTP.Client.TLS as HTTPClient import qualified Network.AWS as Aws @@ -17,7 +18,7 @@ main = do pure . rerouteDynamoDB . rerouteGoogleApis } env <- Aws.newEnv Aws.Discover <&> Aws.envManager .~ mgr - let projectId = DeckGo.Handler.FirebaseProjectId "my-project-id" + let projectId = ProjectId "my-project-id" Warp.run 8080 $ DeckGo.Handler.application mgr projectId env rerouteDynamoDB :: HTTPClient.Request -> HTTPClient.Request diff --git a/infra/handler/package.yaml b/infra/handler/package.yaml index 31c90722a..6f44e26a5 100644 --- a/infra/handler/package.yaml +++ b/infra/handler/package.yaml @@ -5,23 +5,24 @@ license: AGPL-3 dependencies: - aeson - - bytestring + #- bytestring - mtl - amazonka - amazonka-dynamodb - base - - jose + #- jose - lens - random - servant - - x509 - - word8 - - pem + #- x509 + #- word8 + #- pem - http-client - - http-client-tls - - http-conduit - - network-uri - - servant-client-core + #- http-client-tls + #- http-conduit + #- network-uri + #- servant-client-core + - firebase-login - servant-server - text - unliftio diff --git a/infra/handler/src/DeckGo/Handler.hs b/infra/handler/src/DeckGo/Handler.hs index da42c039d..b5f352f9d 100644 --- a/infra/handler/src/DeckGo/Handler.hs +++ b/infra/handler/src/DeckGo/Handler.hs @@ -15,163 +15,35 @@ module DeckGo.Handler where --- TODO: double check what to return on 200 from DynamoDB +-- TODO: double check what is returned on 200 from DynamoDB import Control.Lens hiding ((.=)) import Control.Monad import Control.Monad.Except import Data.Aeson ((.=), (.:), (.!=), (.:?)) import Data.Proxy -import Data.Word8 (isSpace, toLower) import Servant (Context ((:.))) import Servant.API import UnliftIO -import qualified Crypto.JOSE.JWK as JWK -import qualified Network.URI as URI -import qualified Crypto.JWT as JWT import qualified Data.Aeson as Aeson -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BL import qualified Data.HashMap.Strict as HMS -import qualified Data.PEM as PEM import qualified Data.Text as T import qualified Data.Text.Encoding as T -import qualified Data.X509 as X509 import qualified Network.AWS as Aws import qualified Network.AWS.DynamoDB as DynamoDB import qualified Network.HTTP.Client as HTTP -import qualified Network.HTTP.Simple as HTTP import qualified Network.Wai as Wai import qualified Servant as Servant -import qualified Servant.Client.Core as Servant -import qualified Servant.Client.Core as Servant.Client -import qualified Servant.Server.Internal.RoutingApplication as Servant +import Servant.Auth.Firebase (Protected) +import qualified Servant.Auth.Firebase as Firebase import qualified System.Random as Random -newtype FirebaseProjectId = FirebaseProjectId { unFirebaseProjectId :: T.Text } -data ServerContext = ServerContext { firebaseProjectId :: FirebaseProjectId } - -newtype UserId = UserId { unUserId :: T.Text } - deriving newtype (Aeson.FromJSON, Aeson.ToJSON, Show, Eq) - -newtype UnverifiedJWT = UnverifiedJWT JWT.SignedJWT - --- TODO: MAKE SURE PATTERN MATCH FAILURES AREN'T PROPAGATED TO CLIENT!!! -verifyUser :: HTTP.Manager -> FirebaseProjectId -> UnverifiedJWT -> IO UserId -verifyUser mgr (FirebaseProjectId projectId) (UnverifiedJWT jwt) = do - - -- TODO: proper error handling here - let req = - HTTP.setRequestSecure True . - HTTP.setRequestHost "www.googleapis.com" . - HTTP.setRequestPath "/robot/v1/metadata/x509/securetoken@system.gserviceaccount.com" . - HTTP.setRequestManager mgr $ - HTTP.defaultRequest - jwkmap <- HTTP.getResponseBody <$> HTTP.httpJSON req - - t <- case jwt ^.. JWT.signatures . JWT.header . JWT.kid of - [Just (JWT.HeaderParam () t)] -> pure t - xs -> error $ "Expected exactly one signature with 'kid', got: " <> show xs - - jwkct <- case HMS.lookup t jwkmap of - Nothing -> error $ "Could not find key " <> show t <> " in response" - Just ct -> pure ct - - -- TODO: get rid of 'error' - pem <- case PEM.pemParseBS (T.encodeUtf8 jwkct) of - Left e -> error $ show e - Right [e] -> pure e - Right xs -> error $ show xs - - cert <- case X509.decodeSignedCertificate (PEM.pemContent pem) of - Left e -> error $ show e - Right c -> pure c - - jwk <- runExceptT (JWK.fromX509Certificate cert) >>= \case - Left (e :: JWT.JWTError) -> error $ show e - Right jwk -> pure jwk - - issUri <- case URI.parseURI $ "https://securetoken.google.com/" <> T.unpack projectId of - Just issUri -> pure issUri - Nothing -> error $ "Could not use project ID in URI" - - let config = - JWT.defaultJWTValidationSettings - (\sou -> Just projectId == sou ^? JWT.string) & -- aud - JWT.issuerPredicate .~ (\sou -> Just issUri == sou ^? JWT.uri) -- iss - runExceptT (JWT.verifyClaims config jwk jwt) >>= \case - -- TODO: get user from claims - -- TODO: check all the claims - Right cs -> do - case cs ^. JWT.claimSub of - Nothing -> error "Could not get a subject from claim set" - Just sou -> case sou ^? JWT.string of - Nothing -> error "Expected subject to be string" - Just u -> pure (UserId u) - Left (e :: JWT.JWTError) -> error (show e) - -instance FromHttpApiData UnverifiedJWT where - parseUrlPiece = const $ Left "No support for JWT" - parseHeader bs = case JWT.decodeCompact (BL.fromStrict bs) of - Left (e :: JWT.Error) -> Left $ T.pack $ show e - Right jwt -> Right $ UnverifiedJWT jwt - -instance - ( Servant.HasClient m sub - , Servant.RunClient m ) => Servant.HasClient m (Protected :> sub) where - -- TODO: something better than just Text - type Client m (Protected :> sub) = T.Text -> Servant.Client m sub - clientWithRoute p1 Proxy req = \bs -> - Servant.clientWithRoute - p1 (Proxy :: Proxy sub) - (Servant.Client.addHeader "Authorization" ("Bearer " <> bs) req) - hoistClientMonad p1 Proxy hoist c = \bs -> - Servant.Client.hoistClientMonad p1 (Proxy :: Proxy sub) hoist (c bs) - --- | Find and decode an 'Authorization' header from the request as JWT -decodeJWTHdr :: Wai.Request -> Either String UnverifiedJWT -decodeJWTHdr req = do - ah <- case lookup "Authorization" (Wai.requestHeaders req) of - Just x -> Right x - Nothing -> Left "No authorization header" - let (b, rest) = BS.break isSpace ah - guard (BS.map toLower b == "bearer") - tok <- case snd <$> BS.uncons rest of - Nothing -> Left "No token" - Just x -> Right x - case JWT.decodeCompact (BL.fromStrict tok) of - Left (e :: JWT.Error) -> Left $ show e <> ": " <> show rest - Right jwt -> Right (UnverifiedJWT jwt) - -runJWTAuth :: HTTP.Manager -> FirebaseProjectId -> Wai.Request -> Servant.DelayedIO UserId -runJWTAuth mgr projectId req = case decodeJWTHdr req of - Left e -> error $ "bad auth: " <> e -- TODO: delayedFailFatal - Right ujwt -> liftIO $ verifyUser mgr projectId ujwt - -instance - ( Servant.HasContextEntry context FirebaseProjectId - , Servant.HasContextEntry context HTTP.Manager - , Servant.HasServer sub context - ) => Servant.HasServer (Protected :> sub) context where - type ServerT (Protected :> sub) m = UserId -> Servant.ServerT sub m - - route Proxy c subserver = do - Servant.route (Proxy :: Proxy sub) - c (subserver `Servant.addAuthCheck` authCheck) - where - authCheck :: Servant.DelayedIO UserId - authCheck = Servant.withRequest $ runJWTAuth - (Servant.getContextEntry c) (Servant.getContextEntry c) - - hoistServerWithContext Proxy p hoist s = \uid -> - Servant.hoistServerWithContext (Proxy :: Proxy sub) p hoist (s uid) +data ServerContext = ServerContext { firebaseProjectId :: Firebase.ProjectId } ------------------------------------------------------------------------------ -- API ------------------------------------------------------------------------------ -data Protected - data WithId id a = WithId id a deriving (Show, Eq) @@ -273,7 +145,7 @@ api = Proxy -- SERVER ------------------------------------------------------------------------------ -application :: HTTP.Manager -> FirebaseProjectId -> Aws.Env -> Wai.Application +application :: HTTP.Manager -> Firebase.ProjectId -> Aws.Env -> Wai.Application application mgr projectId env = Servant.serveWithContext api @@ -296,7 +168,7 @@ server env = serveDecks :<|> serveSlides slidesPut env :<|> slidesDelete env -decksGet :: Aws.Env -> UserId -> Servant.Handler [WithId DeckId Deck] +decksGet :: Aws.Env -> Firebase.UserId -> Servant.Handler [WithId DeckId Deck] decksGet env _uid = do res <- runAWS env $ Aws.send $ DynamoDB.scan "Decks" case res of @@ -310,7 +182,7 @@ decksGet env _uid = do liftIO $ print e Servant.throwError Servant.err500 -decksGetDeckId :: Aws.Env -> UserId -> DeckId -> Servant.Handler (WithId DeckId Deck) +decksGetDeckId :: Aws.Env -> Firebase.UserId -> DeckId -> Servant.Handler (WithId DeckId Deck) decksGetDeckId env _ deckId = do res <- runAWS env $ Aws.send $ DynamoDB.getItem "Decks" & DynamoDB.giKey .~ HMS.singleton "DeckId" (deckIdToAttributeValue deckId) @@ -352,7 +224,7 @@ decksPost env deck = do pure $ WithId deckId deck -decksPut :: Aws.Env -> UserId -> DeckId -> Deck -> Servant.Handler (WithId DeckId Deck) +decksPut :: Aws.Env -> Firebase.UserId -> DeckId -> Deck -> Servant.Handler (WithId DeckId Deck) decksPut env _ deckId deck = do res <- runAWS env $ Aws.send $ DynamoDB.updateItem "Decks" & @@ -370,7 +242,7 @@ decksPut env _ deckId deck = do pure $ WithId deckId deck -decksDelete :: Aws.Env -> UserId -> DeckId -> Servant.Handler () +decksDelete :: Aws.Env -> Firebase.UserId -> DeckId -> Servant.Handler () decksDelete env _ deckId = do res <- runAWS env $ Aws.send $ DynamoDB.deleteItem "Decks" & diff --git a/infra/nix/default.nix b/infra/nix/default.nix index c21cd74d2..b82be1fa9 100644 --- a/infra/nix/default.nix +++ b/infra/nix/default.nix @@ -26,6 +26,7 @@ with rec super // mkPackage "deckdeckgo-handler" ../handler // ( mkPackage "wai-lambda" wai-lambda.wai-lambda-source ) // + ( mkPackage "firebase-login" ../firebase-login ) // { jose = super.callCabal2nix "jose" sources.hs-jose {}; } ; }; normalHaskellPackages = pkgsStatic.pkgsMusl.haskellPackages.override From 1f9b299d9eb4e8afd0cafaf1e4b976b5f7ed7f06 Mon Sep 17 00:00:00 2001 From: Nicolas Mattia Date: Sat, 30 Mar 2019 12:47:57 +0100 Subject: [PATCH 08/19] handler: ping dynamodb version --- infra/nix/sources.json | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/infra/nix/sources.json b/infra/nix/sources.json index 8480d96b3..868480f8c 100644 --- a/infra/nix/sources.json +++ b/infra/nix/sources.json @@ -21,7 +21,7 @@ "rev": "88ae8f7d55efa457c95187011eb410d097108445" }, "dynamodb": { - "url": "https://s3.eu-central-1.amazonaws.com/dynamodb-local-frankfurt/dynamodb_local_latest.tar.gz", + "url": "https://s3.eu-central-1.amazonaws.com/dynamodb-local-frankfurt/dynamodb_local_2019-02-07.tar.gz", "url_template": "https://github.com///archive/.tar.gz", "type": "file", "sha256": "0hrwxg4igyll40y7l1s0icg55g247fl8cjs4rrcpjf8d7m0bb09j" From 13846de72d395dbcdf6490742f456b47f19cee10 Mon Sep 17 00:00:00 2001 From: Nicolas Mattia Date: Sat, 30 Mar 2019 15:41:57 +0100 Subject: [PATCH 09/19] handler: add dummy swagger --- infra/handler/app/Swagger.hs | 33 +++++++++++ infra/handler/package.yaml | 17 +++--- infra/handler/src/DeckGo/Handler.hs | 29 +++++++++- .../src/Servant/Swagger/UI/Extended.hs | 56 +++++++++++++++++++ 4 files changed, 123 insertions(+), 12 deletions(-) create mode 100644 infra/handler/app/Swagger.hs create mode 100644 infra/handler/src/Servant/Swagger/UI/Extended.hs diff --git a/infra/handler/app/Swagger.hs b/infra/handler/app/Swagger.hs new file mode 100644 index 000000000..0156d120b --- /dev/null +++ b/infra/handler/app/Swagger.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} + +module Main where + +import Data.Proxy +import qualified Data.Swagger as Swagger +import qualified DeckGo.Handler +import qualified Network.Wai.Handler.Warp as Warp +import qualified Servant as Servant +import qualified Servant.Swagger as Servant +import qualified Servant.Swagger.UI.Extended as Servant + +-- | API type with bells and whistles, i.e. schema file and swagger-ui. +type SwaggerAPI = Servant.SwaggerSchemaUI "" "swagger.json" + +swaggerApi :: Proxy SwaggerAPI +swaggerApi = Proxy + +main :: IO () +main = serverSwagger + +swagger :: Swagger.Swagger +swagger = Servant.toSwagger (Proxy :: Proxy DeckGo.Handler.SlidesAPI) + +dumpSwagger :: FilePath -> IO () +dumpSwagger out = Servant.swaggerSchemaUiDump out swaggerApi (Proxy :: Proxy DeckGo.Handler.SlidesAPI) + +serverSwagger :: IO () +serverSwagger = + Warp.run 3000 $ + Servant.serve swaggerApi $ + Servant.swaggerSchemaUIServer swagger diff --git a/infra/handler/package.yaml b/infra/handler/package.yaml index 6f44e26a5..40d0c8dc5 100644 --- a/infra/handler/package.yaml +++ b/infra/handler/package.yaml @@ -5,23 +5,14 @@ license: AGPL-3 dependencies: - aeson - #- bytestring - mtl - amazonka - amazonka-dynamodb - base - #- jose - lens - random - servant - #- x509 - #- word8 - #- pem - http-client - #- http-client-tls - #- http-conduit - #- network-uri - #- servant-client-core - firebase-login - servant-server - text @@ -45,6 +36,14 @@ executables: dependencies: - deckdeckgo-handler + # The API + swagger: + main: app/Swagger.hs + dependencies: + - deckdeckgo-handler + - servant-swagger + - servant-swagger-ui + server: main: app/Server.hs dependencies: diff --git a/infra/handler/src/DeckGo/Handler.hs b/infra/handler/src/DeckGo/Handler.hs index b5f352f9d..d7e7a5281 100644 --- a/infra/handler/src/DeckGo/Handler.hs +++ b/infra/handler/src/DeckGo/Handler.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE LambdaCase #-} @@ -16,7 +17,8 @@ module DeckGo.Handler where -- TODO: double check what is returned on 200 from DynamoDB - +import Data.Swagger +import GHC.Generics import Control.Lens hiding ((.=)) import Control.Monad import Control.Monad.Except @@ -45,7 +47,17 @@ data ServerContext = ServerContext { firebaseProjectId :: Firebase.ProjectId } ------------------------------------------------------------------------------ data WithId id a = WithId id a - deriving (Show, Eq) + deriving (Show, Eq, Generic) + +instance ToSchema (WithId SlideId Slide) where + declareNamedSchema _ = pure $ NamedSchema (Just "SlideWithId") mempty + +instance ToSchema Slide where + declareNamedSchema _ = pure $ NamedSchema (Just "Slide") mempty + + +instance ToParamSchema (WithId SlideId Slide) where + toParamSchema _ = mempty newtype DeckId = DeckId { unDeckId :: T.Text } deriving newtype (Aeson.FromJSON, Aeson.ToJSON, FromHttpApiData, ToHttpApiData, Show, Eq) @@ -55,7 +67,18 @@ data Deck = Deck } deriving (Show, Eq) newtype SlideId = SlideId { unSlideId :: T.Text } - deriving newtype (Aeson.FromJSON, Aeson.ToJSON, FromHttpApiData, ToHttpApiData, Show, Eq) + deriving newtype + ( Aeson.FromJSON + , Aeson.ToJSON + , FromHttpApiData + , ToHttpApiData + , Show + , Eq + ) + deriving stock + ( Generic ) + +instance ToParamSchema SlideId data Slide = Slide { slideContent :: T.Text diff --git a/infra/handler/src/Servant/Swagger/UI/Extended.hs b/infra/handler/src/Servant/Swagger/UI/Extended.hs new file mode 100644 index 000000000..38b67a9e0 --- /dev/null +++ b/infra/handler/src/Servant/Swagger/UI/Extended.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} + +module Servant.Swagger.UI.Extended + ( module Servant.Swagger.UI.Extended + , module Servant.Swagger.UI + ) where + +import Data.Proxy +import GHC.TypeLits +import Control.Monad +import Data.Bifunctor (first) +import System.FilePath (()) +import qualified System.FilePath as FilePath +import qualified Data.Aeson as Aeson +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Servant.Swagger as Servant +import Servant.Swagger.UI +import qualified Servant.Swagger.UI as SwaggerUI +import qualified System.Directory as Directory + +-- | Dump the swagger schema and swagger-ui files to a directory. +swaggerSchemaUiDump + :: forall dir api schema + . (KnownSymbol dir, KnownSymbol schema, Servant.HasSwagger api) + => FilePath -- ^ directory in which to write + -> Proxy (SwaggerUI.SwaggerSchemaUI dir schema) + -> Proxy api + -> IO () +swaggerSchemaUiDump outDir Proxy p = do + let dir = symbolVal @dir Proxy + schema = symbolVal @schema Proxy + index = T.encodeUtf8 $ + T.replace "SERVANT_SWAGGER_UI_SCHEMA" (T.pack schema) $ + T.replace "SERVANT_SWAGGER_UI_DIR" (T.pack dir) $ + SwaggerUI.swaggerUiIndexTemplate + swagger = Servant.toSwagger p + -- The paths are prepended with '/' which confuses + uiFiles = first (dropWhile (== '/')) <$> SwaggerUI.swaggerUiFiles + prefix = case dir of + "" -> outDir + _ -> outDir dir + let allFiles = + [(outDir schema, BL.toStrict $ Aeson.encode swagger)] <> + [(prefix "index.html", index)] <> + (first (prefix ) <$> uiFiles) + + forM_ allFiles $ \(path, content) -> do + Directory.createDirectoryIfMissing + True (FilePath.takeDirectory path) + BS.writeFile path content From ba68c51e855549dafa19fcaea6ed69de1837d3e7 Mon Sep 17 00:00:00 2001 From: Nicolas Mattia Date: Sat, 30 Mar 2019 16:29:07 +0100 Subject: [PATCH 10/19] handler: fix dependencies --- infra/handler/package.yaml | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/infra/handler/package.yaml b/infra/handler/package.yaml index 40d0c8dc5..bf165a37a 100644 --- a/infra/handler/package.yaml +++ b/infra/handler/package.yaml @@ -5,16 +5,22 @@ license: AGPL-3 dependencies: - aeson - - mtl - amazonka - amazonka-dynamodb - base + - bytestring + - directory + - filepath + - firebase-login + - http-client - lens + - mtl - random - servant - - http-client - - firebase-login + - swagger2 - servant-server + - servant-swagger + - servant-swagger-ui - text - unliftio - unordered-containers @@ -40,6 +46,7 @@ executables: swagger: main: app/Swagger.hs dependencies: + - warp - deckdeckgo-handler - servant-swagger - servant-swagger-ui From 3019cf70a783eef27f5a910f0981cbf84af54179 Mon Sep 17 00:00:00 2001 From: Nicolas Mattia Date: Sat, 30 Mar 2019 16:29:15 +0100 Subject: [PATCH 11/19] handler: add test script --- infra/script/test | 4 ++++ 1 file changed, 4 insertions(+) create mode 100755 infra/script/test diff --git a/infra/script/test b/infra/script/test new file mode 100755 index 000000000..8a3c975f8 --- /dev/null +++ b/infra/script/test @@ -0,0 +1,4 @@ +#!/usr/bin/env bash +# vim: filetype=sh + +nix-build --no-link From 0e529d820d9c9bf6da78fbbb2dfc7af84453a866 Mon Sep 17 00:00:00 2001 From: Nicolas Mattia Date: Sat, 30 Mar 2019 23:18:35 +0100 Subject: [PATCH 12/19] handler: implement users --- infra/default.nix | 9 + infra/dynamo.tf | 14 +- infra/handler/app/Swagger.hs | 9 +- infra/handler/app/Test.hs | 25 +- infra/handler/src/DeckGo/Handler.hs | 470 ++++++++++++++++++++++------ 5 files changed, 419 insertions(+), 108 deletions(-) diff --git a/infra/default.nix b/infra/default.nix index 559faddf3..f87485719 100644 --- a/infra/default.nix +++ b/infra/default.nix @@ -51,6 +51,15 @@ rec export AWS_ACCESS_KEY_ID=dummy export AWS_SECRET_ACCESS_KEY=dummy + aws dynamodb create-table \ + --table-name Users \ + --attribute-definitions \ + AttributeName=UserId,AttributeType=S \ + --key-schema AttributeName=UserId,KeyType=HASH \ + --endpoint-url http://127.0.0.1:8000 \ + --provisioned-throughput ReadCapacityUnits=1,WriteCapacityUnits=1 \ + > /dev/null + aws dynamodb create-table \ --table-name Decks \ --attribute-definitions \ diff --git a/infra/dynamo.tf b/infra/dynamo.tf index b58d7e9f1..004518e7e 100644 --- a/infra/dynamo.tf +++ b/infra/dynamo.tf @@ -1,4 +1,16 @@ -resource "aws_dynamodb_table" "deckdeckgo-test-dynamodb-table" { +resource "aws_dynamodb_table" "deckdeckgo-test-dynamodb-table-users" { + name = "Users" + billing_mode = "PAY_PER_REQUEST" + hash_key = "UserId" + + attribute { + name = "UserId" + type = "S" + } + +} + +resource "aws_dynamodb_table" "deckdeckgo-test-dynamodb-table-decks" { name = "Decks" billing_mode = "PAY_PER_REQUEST" hash_key = "DeckId" diff --git a/infra/handler/app/Swagger.hs b/infra/handler/app/Swagger.hs index 0156d120b..ef67defb3 100644 --- a/infra/handler/app/Swagger.hs +++ b/infra/handler/app/Swagger.hs @@ -11,14 +11,13 @@ import qualified Servant as Servant import qualified Servant.Swagger as Servant import qualified Servant.Swagger.UI.Extended as Servant --- | API type with bells and whistles, i.e. schema file and swagger-ui. -type SwaggerAPI = Servant.SwaggerSchemaUI "" "swagger.json" +type SwaggerAPI = Servant.SwaggerSchemaUI "swagger-ui" "swagger.json" swaggerApi :: Proxy SwaggerAPI swaggerApi = Proxy main :: IO () -main = serverSwagger +main = serveSwagger swagger :: Swagger.Swagger swagger = Servant.toSwagger (Proxy :: Proxy DeckGo.Handler.SlidesAPI) @@ -26,8 +25,8 @@ swagger = Servant.toSwagger (Proxy :: Proxy DeckGo.Handler.SlidesAPI) dumpSwagger :: FilePath -> IO () dumpSwagger out = Servant.swaggerSchemaUiDump out swaggerApi (Proxy :: Proxy DeckGo.Handler.SlidesAPI) -serverSwagger :: IO () -serverSwagger = +serveSwagger :: IO () +serveSwagger = Warp.run 3000 $ Servant.serve swaggerApi $ Servant.swaggerSchemaUIServer swagger diff --git a/infra/handler/app/Test.hs b/infra/handler/app/Test.hs index bb7f8cb2e..7885fdebc 100644 --- a/infra/handler/app/Test.hs +++ b/infra/handler/app/Test.hs @@ -20,12 +20,17 @@ main = do let clientEnv = mkClientEnv manager' (BaseUrl Http "localhost" 8080 "") + runClientM usersGet' clientEnv >>= \case + Left err -> error $ "Expected users, got error: " <> show err + Right [] -> pure () + Right decks -> error $ "Expected 0 users, got: " <> show decks + runClientM (decksGet' b) clientEnv >>= \case Left err -> error $ "Expected decks, got error: " <> show err Right [] -> pure () Right decks -> error $ "Expected 0 decks, got: " <> show decks - let someDeck = Deck { deckSlides = [] } + let someDeck = Deck { deckSlides = [] , deckDeckname = Deckname "foo" } deckId <- runClientM (decksPost' someDeck) clientEnv >>= \case Left err -> error $ "Expected new deck, got error: " <> show err @@ -37,7 +42,7 @@ main = do Left err -> error $ "Expected new slide, got error: " <> show err Right (WithId slideId _) -> pure slideId - let newDeck = Deck { deckSlides = [ slideId ] } + let newDeck = Deck { deckSlides = [ slideId ], deckDeckname = Deckname "bar" } runClientM (decksPut' b deckId newDeck) clientEnv >>= \case Left err -> error $ "Expected updated deck, got error: " <> show err @@ -92,18 +97,32 @@ main = do Right decks -> if decks == [] then pure () else (error $ "Expected no decks, got: " <> show decks) --- 'client' allows you to produce operations to query an API from a client. + +usersGet' :: ClientM [WithId UserId User] +_usersGetUserId' :: UserId -> ClientM (WithId UserId User) +_usersPost' :: T.Text -> User -> ClientM (WithId UserId User) +_usersPut' :: T.Text -> UserId -> User -> ClientM (WithId UserId User) +_usersDelete' :: T.Text -> UserId -> ClientM () + decksGet' :: T.Text -> ClientM [WithId DeckId Deck] decksGetDeckId' :: T.Text -> DeckId -> ClientM (WithId DeckId Deck) decksPost' :: Deck -> ClientM (WithId DeckId Deck) decksPut' :: T.Text -> DeckId -> Deck -> ClientM (WithId DeckId Deck) decksDelete' :: T.Text -> DeckId -> ClientM () + slidesGet' :: ClientM [WithId SlideId Slide] slidesGetSlideId' :: SlideId -> ClientM (WithId SlideId Slide) slidesPost' :: Slide -> ClientM (WithId SlideId Slide) slidesPut' :: SlideId -> Slide -> ClientM (WithId SlideId Slide) slidesDelete' :: SlideId -> ClientM () (( + usersGet' :<|> + _usersGetUserId' :<|> + _usersPost' :<|> + _usersPut' :<|> + _usersDelete' + ) :<|> + ( decksGet' :<|> decksGetDeckId' :<|> decksPost' :<|> diff --git a/infra/handler/src/DeckGo/Handler.hs b/infra/handler/src/DeckGo/Handler.hs index d7e7a5281..9b379dd2c 100644 --- a/infra/handler/src/DeckGo/Handler.hs +++ b/infra/handler/src/DeckGo/Handler.hs @@ -17,15 +17,17 @@ module DeckGo.Handler where -- TODO: double check what is returned on 200 from DynamoDB -import Data.Swagger -import GHC.Generics + import Control.Lens hiding ((.=)) import Control.Monad import Control.Monad.Except import Data.Aeson ((.=), (.:), (.!=), (.:?)) import Data.Proxy +import Data.Swagger +import GHC.Generics import Servant (Context ((:.))) import Servant.API +import Servant.Auth.Firebase (Protected) import UnliftIO import qualified Data.Aeson as Aeson import qualified Data.HashMap.Strict as HMS @@ -36,7 +38,6 @@ import qualified Network.AWS.DynamoDB as DynamoDB import qualified Network.HTTP.Client as HTTP import qualified Network.Wai as Wai import qualified Servant as Servant -import Servant.Auth.Firebase (Protected) import qualified Servant.Auth.Firebase as Firebase import qualified System.Random as Random @@ -46,26 +47,156 @@ data ServerContext = ServerContext { firebaseProjectId :: Firebase.ProjectId } -- API ------------------------------------------------------------------------------ +-- COMMON + + data WithId id a = WithId id a deriving (Show, Eq, Generic) -instance ToSchema (WithId SlideId Slide) where - declareNamedSchema _ = pure $ NamedSchema (Just "SlideWithId") mempty +-- USERS -instance ToSchema Slide where - declareNamedSchema _ = pure $ NamedSchema (Just "Slide") mempty +type UsersAPI = + Get '[JSON] [WithId UserId User] :<|> + Capture "user_id" UserId :> Get '[JSON] (WithId UserId User) :<|> + Protected :> + ReqBody '[JSON] User :> + Post '[JSON] (WithId UserId User) :<|> + Protected :> + Capture "user_id" UserId :> + ReqBody '[JSON] User :> Put '[JSON] (WithId UserId User) :<|> + Protected :> Capture "user_id" UserId :> Delete '[JSON] () + +newtype Username = Username { unUsername :: T.Text } + deriving stock (Show, Eq) + deriving newtype (Aeson.FromJSON, Aeson.ToJSON) + +data User = User + { userDecks :: [DeckId] + , userFirebaseId :: FirebaseId -- TODO: enforce uniqueness + , userUsername :: Username + } deriving (Show, Eq) +newtype UserId = UserId { unUserId :: T.Text } + deriving newtype + ( Aeson.FromJSON + , Aeson.ToJSON + , FromHttpApiData + , ToHttpApiData + , Show + , Eq + ) + deriving stock + ( Generic ) -instance ToParamSchema (WithId SlideId Slide) where - toParamSchema _ = mempty +newtype FirebaseId = FirebaseId { unFirebaseId :: T.Text } + deriving newtype + ( Aeson.FromJSON + , Aeson.ToJSON + , FromHttpApiData + , ToHttpApiData + , Show + , Eq + ) + deriving stock + ( Generic ) + +instance Aeson.FromJSON User where + parseJSON = Aeson.withObject "user" $ \obj -> + User + <$> obj .: "user_username" + <*> obj .: "user_decks" + <*> obj .: "user_firebaseid" + +instance Aeson.ToJSON User where + toJSON user = Aeson.object + [ "user_username" .= userUsername user + , "user_decks" .= userDecks user + , "user_firebaseid" .= userFirebaseId user + ] + +-- TODO: deduplicate those instances +instance Aeson.FromJSON (WithId UserId User) where + parseJSON = Aeson.withObject "WithId UserId User" $ \o -> + WithId <$> + (UserId <$> o .: "user_id") <*> + (User <$> o .: "user_decks" <*> o .: "user_username" <*> o .: "user_firebaseid") + +instance Aeson.ToJSON (WithId UserId User) where + toJSON (WithId userId user) = Aeson.object + [ "user_id" .= userId + , "user_decks" .= userDecks user + , "user_name" .= userUsername user + ] + +-- DECKS + +type DecksAPI = + Protected :> Get '[JSON] [WithId DeckId Deck] :<|> + Protected :> + Capture "deck_id" DeckId :> + Get '[JSON] (WithId DeckId Deck) :<|> + ReqBody '[JSON] Deck :> Post '[JSON] (WithId DeckId Deck) :<|> --TODO: protect + Protected :> + Capture "deck_id" DeckId :> + ReqBody '[JSON] Deck :> Put '[JSON] (WithId DeckId Deck) :<|> + Protected :> Capture "deck_id" DeckId :> Delete '[JSON] () newtype DeckId = DeckId { unDeckId :: T.Text } deriving newtype (Aeson.FromJSON, Aeson.ToJSON, FromHttpApiData, ToHttpApiData, Show, Eq) +newtype Deckname = Deckname { unDeckname :: T.Text } + deriving stock (Show, Eq) + deriving newtype (Aeson.FromJSON, Aeson.ToJSON) + data Deck = Deck { deckSlides :: [SlideId] + , deckDeckname :: Deckname -- TODO: enforce uniqueness } deriving (Show, Eq) +instance Aeson.FromJSON Deck where + parseJSON = Aeson.withObject "deck" $ \obj -> + Deck + <$> obj .: "deck_slides" + <*> obj .: "deck_name" + +instance Aeson.ToJSON Deck where + toJSON deck = Aeson.object + [ "deck_slides" .= deckSlides deck + , "deck_name" .= deckDeckname deck + ] + +-- TODO: deduplicate those instances +instance Aeson.FromJSON (WithId DeckId Deck) where + parseJSON = Aeson.withObject "WithId DeckId Deck" $ \o -> + WithId <$> + (DeckId <$> o .: "deck_id") <*> + (Deck <$> o .: "deck_slides" <*> o .: "deck_name") + +instance Aeson.ToJSON (WithId DeckId Deck) where + toJSON (WithId deckId deck) = Aeson.object + [ "deck_id" .= deckId + , "deck_slides" .= deckSlides deck + , "deck_name" .= deckDeckname deck + ] + +-- SLIDES + +type SlidesAPI = + Get '[JSON] [WithId SlideId Slide] :<|> + Capture "slide_id" SlideId :> Get '[JSON] (WithId SlideId Slide) :<|> + ReqBody '[JSON] Slide :> Post '[JSON] (WithId SlideId Slide) :<|> + Capture "slide_id" SlideId :> ReqBody '[JSON] Slide :> Put '[JSON] (WithId SlideId Slide) :<|> + Capture "slide_id" SlideId :> Delete '[JSON] () + +instance ToSchema (WithId SlideId Slide) where + declareNamedSchema _ = pure $ NamedSchema (Just "SlideWithId") mempty + +instance ToSchema Slide where + declareNamedSchema _ = pure $ NamedSchema (Just "Slide") mempty + +instance ToParamSchema (WithId SlideId Slide) where + toParamSchema _ = mempty + newtype SlideId = SlideId { unSlideId :: T.Text } deriving newtype ( Aeson.FromJSON @@ -86,15 +217,6 @@ data Slide = Slide , slideAttributes :: HMS.HashMap T.Text T.Text } deriving (Show, Eq) -instance Aeson.FromJSON Deck where - parseJSON = Aeson.withObject "decK" $ \obj -> - Deck <$> obj .: "deck_slides" - -instance Aeson.ToJSON Deck where - toJSON deck = Aeson.object - [ "deck_slides" .= deckSlides deck - ] - instance Aeson.FromJSON Slide where parseJSON = Aeson.withObject "slide" $ \obj -> Slide <$> @@ -109,18 +231,6 @@ instance Aeson.ToJSON Slide where , "slide_content" .= slideContent slide ] -instance Aeson.FromJSON (WithId DeckId Deck) where - parseJSON = Aeson.withObject "WithId DeckId Deck" $ \o -> - WithId <$> - (DeckId <$> o .: "deck_id") <*> - (Deck <$> o .: "deck_slides") - -instance Aeson.ToJSON (WithId DeckId Deck) where - toJSON (WithId deckId deck) = Aeson.object - [ "deck_id" .= deckId - , "deck_slides" .= deckSlides deck - ] - instance Aeson.FromJSON (WithId SlideId Slide) where parseJSON = Aeson.withObject "WithId SlideId Slide" $ \o -> WithId <$> @@ -140,27 +250,10 @@ instance Aeson.ToJSON (WithId SlideId Slide) where ] type API = + "users" :> UsersAPI :<|> "decks" :> DecksAPI :<|> "slides" :> SlidesAPI -type DecksAPI = - Protected :> Get '[JSON] [WithId DeckId Deck] :<|> - Protected :> - Capture "deck_id" DeckId :> - Get '[JSON] (WithId DeckId Deck) :<|> - ReqBody '[JSON] Deck :> Post '[JSON] (WithId DeckId Deck) :<|> - Protected :> - Capture "deck_id" DeckId :> - ReqBody '[JSON] Deck :> Put '[JSON] (WithId DeckId Deck) :<|> - Protected :> Capture "deck_id" DeckId :> Delete '[JSON] () - -type SlidesAPI = - Get '[JSON] [WithId SlideId Slide] :<|> - Capture "slide_id" SlideId :> Get '[JSON] (WithId SlideId Slide) :<|> - ReqBody '[JSON] Slide :> Post '[JSON] (WithId SlideId Slide) :<|> - Capture "slide_id" SlideId :> ReqBody '[JSON] Slide :> Put '[JSON] (WithId SlideId Slide) :<|> - Capture "slide_id" SlideId :> Delete '[JSON] () - api :: Proxy API api = Proxy @@ -176,8 +269,14 @@ application mgr projectId env = (server env) server :: Aws.Env -> Servant.Server API -server env = serveDecks :<|> serveSlides +server env = serveUsers :<|> serveDecks :<|> serveSlides where + serveUsers = + usersGet env :<|> + usersGetUserId env :<|> + usersPost env :<|> + usersPut env :<|> + usersDelete env serveDecks = decksGet env :<|> decksGetDeckId env :<|> @@ -191,6 +290,98 @@ server env = serveDecks :<|> serveSlides slidesPut env :<|> slidesDelete env +-- USERS + +usersGet :: Aws.Env -> Servant.Handler [WithId UserId User] +usersGet env = do + res <- runAWS env $ Aws.send $ DynamoDB.scan "Users" + case res of + Right scanResponse -> + case sequence $ scanResponse ^. DynamoDB.srsItems <&> itemToUser of + Nothing -> do + liftIO $ putStrLn $ "Could not parse response: " <> show scanResponse + Servant.throwError Servant.err500 + Just ids -> pure ids + Left e -> do + liftIO $ print e + Servant.throwError Servant.err500 + +usersGetUserId :: Aws.Env -> UserId -> Servant.Handler (WithId UserId User) +usersGetUserId env userId = do + res <- runAWS env $ Aws.send $ DynamoDB.getItem "Users" & + DynamoDB.giKey .~ HMS.singleton "UserId" (userIdToAttributeValue userId) + case res of + Right getItemResponse -> do + case getItemResponse ^. DynamoDB.girsResponseStatus of + 200 -> pure () + 404 -> do + liftIO $ putStrLn $ "Item not found: " <> show getItemResponse + Servant.throwError Servant.err404 + s -> do + liftIO $ + putStrLn $ "Unkown response status: " <> show s <> + " in response " <> show getItemResponse + Servant.throwError Servant.err500 + + case itemToUser (getItemResponse ^. DynamoDB.girsItem) of + Nothing -> do + liftIO $ putStrLn $ "Could not parse response: " <> show getItemResponse + Servant.throwError Servant.err500 + Just user -> pure user + Left e -> do + liftIO $ print e + Servant.throwError Servant.err500 + +usersPost :: Aws.Env -> Firebase.UserId -> User -> Servant.Handler (WithId UserId User) +usersPost env _uid user = do + + userId <- liftIO $ UserId <$> newId + + res <- runAWS env $ Aws.send $ DynamoDB.putItem "Users" & + DynamoDB.piItem .~ userToItem userId user + + case res of + Right {} -> pure () + Left e -> do + liftIO $ print e + Servant.throwError Servant.err500 + + pure $ WithId userId user + +usersPut :: Aws.Env -> Firebase.UserId -> UserId -> User -> Servant.Handler (WithId UserId User) +usersPut env _ userId user = do + + res <- runAWS env $ Aws.send $ DynamoDB.updateItem "Users" & + DynamoDB.uiUpdateExpression .~ + Just "SET UserDecks = :s, UserUsername = :n, UserFirebaseId = :i" & + DynamoDB.uiExpressionAttributeValues .~ userToItem' user & + DynamoDB.uiReturnValues .~ Just DynamoDB.UpdatedNew & + DynamoDB.uiKey .~ HMS.singleton "UserId" + (userIdToAttributeValue userId) + + case res of + Right {} -> pure () + Left e -> do + liftIO $ print e + Servant.throwError Servant.err500 + + pure $ WithId userId user + +usersDelete :: Aws.Env -> Firebase.UserId -> UserId -> Servant.Handler () +usersDelete env _ userId = do + + res <- runAWS env $ Aws.send $ DynamoDB.deleteItem "Users" & + DynamoDB.diKey .~ HMS.singleton "UserId" + (userIdToAttributeValue userId) + + case res of + Right {} -> pure () + Left e -> do + liftIO $ print e + Servant.throwError Servant.err500 + +-- DECKS + decksGet :: Aws.Env -> Firebase.UserId -> Servant.Handler [WithId DeckId Deck] decksGet env _uid = do res <- runAWS env $ Aws.send $ DynamoDB.scan "Decks" @@ -251,7 +442,7 @@ decksPut :: Aws.Env -> Firebase.UserId -> DeckId -> Deck -> Servant.Handler (Wit decksPut env _ deckId deck = do res <- runAWS env $ Aws.send $ DynamoDB.updateItem "Decks" & - DynamoDB.uiUpdateExpression .~ Just "SET DeckSlides = :s" & + DynamoDB.uiUpdateExpression .~ Just "SET DeckSlides = :s, DeckName = :n" & DynamoDB.uiExpressionAttributeValues .~ deckToItem' deck & DynamoDB.uiReturnValues .~ Just DynamoDB.UpdatedNew & DynamoDB.uiKey .~ HMS.singleton "DeckId" @@ -278,13 +469,7 @@ decksDelete env _ deckId = do liftIO $ print e Servant.throwError Servant.err500 -runAWS :: MonadIO m => Aws.Env -> Aws.AWS a -> m (Either SomeException a) -runAWS env = - liftIO . - tryAny . - Aws.runResourceT . - Aws.runAWS env . - Aws.within Aws.NorthVirginia +-- SLIDES slidesGet :: Aws.Env -> Servant.Handler [WithId SlideId Slide] slidesGet env = do @@ -375,56 +560,112 @@ slidesDelete env slideId = do liftIO $ print e Servant.throwError Servant.err500 -randomString :: Int -> [Char] -> IO String -randomString len allowedChars = - replicateM len $ do - idx <- Random.randomRIO (0, length allowedChars - 1) - pure $ allowedChars !! idx +------------------------------------------------------------------------------- +-- DYNAMODB +------------------------------------------------------------------------------- -randomText :: Int -> [Char] -> IO T.Text -randomText len allowedChars = T.pack <$> randomString len allowedChars +-- USERS -newId :: IO T.Text -newId = randomText 32 (['0' .. '9'] <> ['a' .. 'z']) +userToItem :: UserId -> User -> HMS.HashMap T.Text DynamoDB.AttributeValue +userToItem userId User{userDecks, userUsername, userFirebaseId} = + HMS.singleton "UserId" (userIdToAttributeValue userId) <> + HMS.singleton "UserDecks" (userDecksToAttributeValue userDecks) <> + HMS.singleton "UserFirebaseId" (userFirebaseIdToAttributeValue userFirebaseId) <> + HMS.singleton "UserUsername" (userNameToAttributeValue userUsername) -deckIdToAttributeValue :: DeckId -> DynamoDB.AttributeValue -deckIdToAttributeValue (DeckId deckId) = - DynamoDB.attributeValue & DynamoDB.avS .~ Just deckId +userToItem' :: User -> HMS.HashMap T.Text DynamoDB.AttributeValue +userToItem' User{userDecks, userUsername, userFirebaseId} = + HMS.singleton ":s" (userDecksToAttributeValue userDecks) <> + HMS.singleton ":i" (userFirebaseIdToAttributeValue userFirebaseId) <> + HMS.singleton ":n" (userNameToAttributeValue userUsername) -deckIdFromAttributeValue :: DynamoDB.AttributeValue -> Maybe DeckId -deckIdFromAttributeValue attr = DeckId <$> attr ^. DynamoDB.avS +itemToUser :: HMS.HashMap T.Text DynamoDB.AttributeValue -> Maybe (WithId UserId User) +itemToUser item = do + userId <- HMS.lookup "UserId" item >>= userIdFromAttributeValue + userDecks <- HMS.lookup "UserDecks" item >>= userDecksFromAttributeValue + userUsername <- HMS.lookup "UserUsername" item >>= userNameFromAttributeValue + userFirebaseId <- HMS.lookup "UserFirebaseId" item >>= userFirebaseIdFromAttributeValue + pure $ WithId userId User{..} -deckSlidesToAttributeValue :: [SlideId] -> DynamoDB.AttributeValue -deckSlidesToAttributeValue deckSlides = - DynamoDB.attributeValue & DynamoDB.avL .~ - (slideIdToAttributeValue <$> deckSlides) +-- USER ATTRIBUTES -deckSlidesFromAttributeValue :: DynamoDB.AttributeValue -> Maybe [SlideId] -deckSlidesFromAttributeValue attr = - traverse slideIdFromAttributeValue (attr ^. DynamoDB.avL) +userIdToAttributeValue :: UserId -> DynamoDB.AttributeValue +userIdToAttributeValue (UserId userId) = + DynamoDB.attributeValue & DynamoDB.avS .~ Just userId -slideIdToAttributeValue :: SlideId -> DynamoDB.AttributeValue -slideIdToAttributeValue (SlideId slideId) = - DynamoDB.attributeValue & DynamoDB.avS .~ Just slideId +userIdFromAttributeValue :: DynamoDB.AttributeValue -> Maybe UserId +userIdFromAttributeValue attr = UserId <$> attr ^. DynamoDB.avS -slideIdFromAttributeValue :: DynamoDB.AttributeValue -> Maybe SlideId -slideIdFromAttributeValue attr = SlideId <$> attr ^. DynamoDB.avS +userNameToAttributeValue :: Username -> DynamoDB.AttributeValue +userNameToAttributeValue (Username username) = + DynamoDB.attributeValue & DynamoDB.avS .~ Just username + +userNameFromAttributeValue :: DynamoDB.AttributeValue -> Maybe Username +userNameFromAttributeValue attr = Username <$> attr ^. DynamoDB.avS + +userFirebaseIdToAttributeValue :: FirebaseId -> DynamoDB.AttributeValue +userFirebaseIdToAttributeValue (FirebaseId userId) = + DynamoDB.attributeValue & DynamoDB.avS .~ Just userId + +userFirebaseIdFromAttributeValue :: DynamoDB.AttributeValue -> Maybe FirebaseId +userFirebaseIdFromAttributeValue attr = FirebaseId <$> attr ^. DynamoDB.avS + +userDecksToAttributeValue :: [DeckId] -> DynamoDB.AttributeValue +userDecksToAttributeValue userDecks = + DynamoDB.attributeValue & DynamoDB.avL .~ + (deckIdToAttributeValue <$> userDecks) + +userDecksFromAttributeValue :: DynamoDB.AttributeValue -> Maybe [DeckId] +userDecksFromAttributeValue attr = + traverse deckIdFromAttributeValue (attr ^. DynamoDB.avL) + +-- DECKS deckToItem :: DeckId -> Deck -> HMS.HashMap T.Text DynamoDB.AttributeValue -deckToItem deckId Deck{deckSlides} = +deckToItem deckId Deck{deckSlides, deckDeckname} = HMS.singleton "DeckId" (deckIdToAttributeValue deckId) <> - HMS.singleton "DeckSlides" (deckSlidesToAttributeValue deckSlides) + HMS.singleton "DeckSlides" (deckSlidesToAttributeValue deckSlides) <> + HMS.singleton "DeckName" (deckNameToAttributeValue deckDeckname) deckToItem' :: Deck -> HMS.HashMap T.Text DynamoDB.AttributeValue -deckToItem' Deck{deckSlides} = - HMS.singleton ":s" (deckSlidesToAttributeValue deckSlides) +deckToItem' Deck{deckSlides, deckDeckname} = + HMS.singleton ":s" (deckSlidesToAttributeValue deckSlides) <> + HMS.singleton ":n" (deckNameToAttributeValue deckDeckname) itemToDeck :: HMS.HashMap T.Text DynamoDB.AttributeValue -> Maybe (WithId DeckId Deck) itemToDeck item = do deckId <- HMS.lookup "DeckId" item >>= deckIdFromAttributeValue deckSlides <- HMS.lookup "DeckSlides" item >>= deckSlidesFromAttributeValue + deckDeckname <- HMS.lookup "DeckName" item >>= deckNameFromAttributeValue pure $ WithId deckId Deck{..} +-- DECK ATTRIBUTES + +deckIdToAttributeValue :: DeckId -> DynamoDB.AttributeValue +deckIdToAttributeValue (DeckId deckId) = + DynamoDB.attributeValue & DynamoDB.avS .~ Just deckId + +deckNameToAttributeValue :: Deckname -> DynamoDB.AttributeValue +deckNameToAttributeValue (Deckname deckname) = + DynamoDB.attributeValue & DynamoDB.avS .~ Just deckname + +deckNameFromAttributeValue :: DynamoDB.AttributeValue -> Maybe Deckname +deckNameFromAttributeValue attr = Deckname <$> attr ^. DynamoDB.avS + +deckIdFromAttributeValue :: DynamoDB.AttributeValue -> Maybe DeckId +deckIdFromAttributeValue attr = DeckId <$> attr ^. DynamoDB.avS + +deckSlidesToAttributeValue :: [SlideId] -> DynamoDB.AttributeValue +deckSlidesToAttributeValue deckSlides = + DynamoDB.attributeValue & DynamoDB.avL .~ + (slideIdToAttributeValue <$> deckSlides) + +deckSlidesFromAttributeValue :: DynamoDB.AttributeValue -> Maybe [SlideId] +deckSlidesFromAttributeValue attr = + traverse slideIdFromAttributeValue (attr ^. DynamoDB.avL) + +-- SLIDES + slideToItem :: SlideId -> Slide -> HMS.HashMap T.Text DynamoDB.AttributeValue slideToItem slideId Slide{slideContent, slideTemplate, slideAttributes} = HMS.singleton "SlideId" (slideIdToAttributeValue slideId) <> @@ -432,6 +673,32 @@ slideToItem slideId Slide{slideContent, slideTemplate, slideAttributes} = HMS.singleton "SlideTemplate" (slideTemplateToAttributeValue slideTemplate) <> HMS.singleton "SlideAttributes" (slideAttributesToAttributeValue slideAttributes) +slideToItem' :: Slide -> HMS.HashMap T.Text DynamoDB.AttributeValue +slideToItem' Slide{slideContent, slideTemplate, slideAttributes} = + HMS.singleton ":c" (slideContentToAttributeValue slideContent) <> + HMS.singleton ":t" (slideTemplateToAttributeValue slideTemplate) <> + HMS.singleton ":a" (slideAttributesToAttributeValue slideAttributes) + +itemToSlide :: HMS.HashMap T.Text DynamoDB.AttributeValue -> Maybe (WithId SlideId Slide) +itemToSlide item = do + slideId <- HMS.lookup "SlideId" item >>= slideIdFromAttributeValue + + slideContent <- HMS.lookup "SlideContent" item >>= slideContentFromAttributeValue + + slideTemplate <- HMS.lookup "SlideTemplate" item >>= slideTemplateFromAttributeValue + slideAttributes <- HMS.lookup "SlideAttributes" item >>= slideAttributesFromAttributeValue + + pure $ WithId slideId Slide{..} + +-- SLIDE ATTRIBUTES + +slideIdToAttributeValue :: SlideId -> DynamoDB.AttributeValue +slideIdToAttributeValue (SlideId slideId) = + DynamoDB.attributeValue & DynamoDB.avS .~ Just slideId + +slideIdFromAttributeValue :: DynamoDB.AttributeValue -> Maybe SlideId +slideIdFromAttributeValue attr = SlideId <$> attr ^. DynamoDB.avS + slideContentToAttributeValue :: T.Text -> DynamoDB.AttributeValue slideContentToAttributeValue content = DynamoDB.attributeValue & DynamoDB.avB .~ Just (T.encodeUtf8 content) @@ -467,19 +734,24 @@ slideAttributesFromAttributeValue attr = attributeValueFromAttributeValue attrValue = T.decodeUtf8 <$> attrValue ^. DynamoDB.avB -slideToItem' :: Slide -> HMS.HashMap T.Text DynamoDB.AttributeValue -slideToItem' Slide{slideContent, slideTemplate, slideAttributes} = - HMS.singleton ":c" (slideContentToAttributeValue slideContent) <> - HMS.singleton ":t" (slideTemplateToAttributeValue slideTemplate) <> - HMS.singleton ":a" (slideAttributesToAttributeValue slideAttributes) +-- AUX -itemToSlide :: HMS.HashMap T.Text DynamoDB.AttributeValue -> Maybe (WithId SlideId Slide) -itemToSlide item = do - slideId <- HMS.lookup "SlideId" item >>= slideIdFromAttributeValue +runAWS :: MonadIO m => Aws.Env -> Aws.AWS a -> m (Either SomeException a) +runAWS env = + liftIO . + tryAny . + Aws.runResourceT . + Aws.runAWS env . + Aws.within Aws.NorthVirginia - slideContent <- HMS.lookup "SlideContent" item >>= slideContentFromAttributeValue +randomString :: Int -> [Char] -> IO String +randomString len allowedChars = + replicateM len $ do + idx <- Random.randomRIO (0, length allowedChars - 1) + pure $ allowedChars !! idx - slideTemplate <- HMS.lookup "SlideTemplate" item >>= slideTemplateFromAttributeValue - slideAttributes <- HMS.lookup "SlideAttributes" item >>= slideAttributesFromAttributeValue +randomText :: Int -> [Char] -> IO T.Text +randomText len allowedChars = T.pack <$> randomString len allowedChars - pure $ WithId slideId Slide{..} +newId :: IO T.Text +newId = randomText 32 (['0' .. '9'] <> ['a' .. 'z']) From 1a600a5ab6bfc3fbe57a4eb4d806d3f908b72239 Mon Sep 17 00:00:00 2001 From: Nicolas Mattia Date: Sat, 30 Mar 2019 23:52:46 +0100 Subject: [PATCH 13/19] handler: add CircleCI --- .circleci/config.yml | 43 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 43 insertions(+) create mode 100644 .circleci/config.yml diff --git a/.circleci/config.yml b/.circleci/config.yml new file mode 100644 index 000000000..7927c354e --- /dev/null +++ b/.circleci/config.yml @@ -0,0 +1,43 @@ +version: 2 + +jobs: + build: + working_directory: ~/project/infra + machine: + enabled: true + steps: + - checkout: + path: ~/project + + - run: + name: Install Nix + command: | + sudo mkdir -p /nix + sudo chown circleci /nix + bash <(curl https://nixos.org/nix/install) + echo '. /home/circleci/.nix-profile/etc/profile.d/nix.sh' >> $BASH_ENV + sudo mkdir -p /etc/nix + + # Enable sandbox + echo "build-use-sandbox = true" | sudo tee -a /etc/nix/nix.conf + echo "substituters = https://cache.nixos.org https://static-haskell-nix.cachix.org" \ + | sudo tee -a /etc/nix/nix.conf + echo "trusted-public-keys = cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= static-haskell-nix.cachix.org-1:Q17HawmAwaM1/BfIxaEDKAxwTOyRVhPG5Ji9K3+FvUU=" \ + | sudo tee -a /etc/nix/nix.conf + + + + #path: ~/deckdeckgo + + - run: + name: Nix build + command: | + ls + pwd + ./script/test + +workflows: + version: 2 + build: + jobs: + - build From 041af520af981ba35fb6c47ffc45417641e277b3 Mon Sep 17 00:00:00 2001 From: Nicolas Mattia Date: Sun, 31 Mar 2019 00:12:59 +0100 Subject: [PATCH 14/19] handler: cache CI builds --- .circleci/config.yml | 18 +++++++++++++----- 1 file changed, 13 insertions(+), 5 deletions(-) diff --git a/.circleci/config.yml b/.circleci/config.yml index 7927c354e..6a72c56f2 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -20,14 +20,21 @@ jobs: # Enable sandbox echo "build-use-sandbox = true" | sudo tee -a /etc/nix/nix.conf - echo "substituters = https://cache.nixos.org https://static-haskell-nix.cachix.org" \ + echo "substituters = https://cache.nixos.org https://static-haskell-nix.cachix.org https://deckgo.cachix.org" \ | sudo tee -a /etc/nix/nix.conf - echo "trusted-public-keys = cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= static-haskell-nix.cachix.org-1:Q17HawmAwaM1/BfIxaEDKAxwTOyRVhPG5Ji9K3+FvUU=" \ + echo "trusted-public-keys = cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= static-haskell-nix.cachix.org-1:Q17HawmAwaM1/BfIxaEDKAxwTOyRVhPG5Ji9K3+FvUU= deckgo.cachix.org-1:Kx6Rm054j44GugSRodI2R8T7tAr2u63gKbcCQ9wgaUk=" \ | sudo tee -a /etc/nix/nix.conf + - run: + name: Install cachix + command: | + nix-env -iA cachix -f https://cachix.org/api/v1/install - - #path: ~/deckdeckgo + - run: + name: Run cachix + command: | + cachix push deckgo --watch-store + background: true - run: name: Nix build @@ -40,4 +47,5 @@ workflows: version: 2 build: jobs: - - build + - build: + context: cachix From 5e3a59120b2df2a2a4f23cc5440da684b6340314 Mon Sep 17 00:00:00 2001 From: Nicolas Mattia Date: Sun, 31 Mar 2019 19:04:55 +0200 Subject: [PATCH 15/19] handler: deploy swagger and update terraform --- .circleci/config.yml | 32 ++++++++++++++++++++++++++++++-- infra/default.nix | 6 ++++++ infra/handler/app/Swagger.hs | 5 ++++- infra/lambda.tf | 3 ++- 4 files changed, 42 insertions(+), 4 deletions(-) diff --git a/.circleci/config.yml b/.circleci/config.yml index 6a72c56f2..a315425f5 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -39,10 +39,38 @@ jobs: - run: name: Nix build command: | - ls - pwd ./script/test + - run: + name: "Update Node.js and npm" + command: | + nix-env -f ./nix -iA nodejs-10_x + + - run: + name: Install netlify-cli + command: | + npm install netlify-cli + + - run: # TODO: shouldn't deploy to prod on every commit + name: Netlify deploy + command: | + echo "Branch:" "$CIRCLE_BRANCH" + echo "Repo:" "$CIRCLE_REPOSITORY_URL" + echo "PR:" "$CIRCLE_PULL_REQUEST" + if [ "$CIRCLE_BRANCH" == "master" ]; then + echo "Deploying to production" + ./node_modules/netlify-cli/bin/run deploy \ + --dir=$(nix-build -A swaggerUi --no-link) \ + --message="$CIRCLE_SHA1" --prod + elif [ -n "$CIRCLE_PULL_REQUEST" ]; then + echo "One time deploy for PR $CIRCLE_PR_NUMBER" + ./node_modules/netlify-cli/bin/run deploy \ + --dir=$(nix-build -A swaggerUi --no-link) \ + --message="$CIRCLE_SHA1" + else + echo "Not deploying" + fi + workflows: version: 2 build: diff --git a/infra/default.nix b/infra/default.nix index f87485719..94ed8c8cd 100644 --- a/infra/default.nix +++ b/infra/default.nix @@ -16,6 +16,12 @@ rec publicKey = builtins.readFile ./public.cer; + swaggerUi = pkgs.runCommand "swagger-ui" {} + '' + mkdir -p $out + ${handler}/bin/swagger $out + ''; + googleResp = { "key1" = publicKey ; }; apiDir = pkgs.writeTextFile diff --git a/infra/handler/app/Swagger.hs b/infra/handler/app/Swagger.hs index ef67defb3..f8095faac 100644 --- a/infra/handler/app/Swagger.hs +++ b/infra/handler/app/Swagger.hs @@ -10,6 +10,7 @@ import qualified Network.Wai.Handler.Warp as Warp import qualified Servant as Servant import qualified Servant.Swagger as Servant import qualified Servant.Swagger.UI.Extended as Servant +import System.Environment (getArgs) type SwaggerAPI = Servant.SwaggerSchemaUI "swagger-ui" "swagger.json" @@ -17,7 +18,9 @@ swaggerApi :: Proxy SwaggerAPI swaggerApi = Proxy main :: IO () -main = serveSwagger +main = do + [dir] <- getArgs + dumpSwagger dir swagger :: Swagger.Swagger swagger = Servant.toSwagger (Proxy :: Proxy DeckGo.Handler.SlidesAPI) diff --git a/infra/lambda.tf b/infra/lambda.tf index 50060c613..e8d864813 100644 --- a/infra/lambda.tf +++ b/infra/lambda.tf @@ -60,8 +60,9 @@ data "aws_iam_policy_document" "policy_for_lambda" { ] resources = [ - "${aws_dynamodb_table.deckdeckgo-test-dynamodb-table.arn}", + "${aws_dynamodb_table.deckdeckgo-test-dynamodb-table-decks.arn}", "${aws_dynamodb_table.deckdeckgo-test-dynamodb-table-slides.arn}", + "${aws_dynamodb_table.deckdeckgo-test-dynamodb-table-users.arn}", ] } From 00477dc0c189edc367f0f2cadf2d8343014edfa9 Mon Sep 17 00:00:00 2001 From: Nicolas Mattia Date: Sat, 6 Apr 2019 14:16:47 +0200 Subject: [PATCH 16/19] handler: add decks by owner --- .../src/Servant/Auth/Firebase.hs | 1 + infra/handler/app/Handler.hs | 2 +- infra/handler/app/Test.hs | 18 +-- infra/handler/src/DeckGo/Handler.hs | 117 ++++++++++++------ 4 files changed, 93 insertions(+), 45 deletions(-) diff --git a/infra/firebase-login/src/Servant/Auth/Firebase.hs b/infra/firebase-login/src/Servant/Auth/Firebase.hs index f8ca8b035..1108dac83 100644 --- a/infra/firebase-login/src/Servant/Auth/Firebase.hs +++ b/infra/firebase-login/src/Servant/Auth/Firebase.hs @@ -53,6 +53,7 @@ verifyUser mgr (ProjectId projectId) (UnverifiedJWT jwt) = do -- TODO: proper error handling here let req = HTTP.setRequestSecure True . + HTTP.setRequestPort 443 . HTTP.setRequestHost "www.googleapis.com" . HTTP.setRequestPath "/robot/v1/metadata/x509/securetoken@system.gserviceaccount.com" . HTTP.setRequestManager mgr $ diff --git a/infra/handler/app/Handler.hs b/infra/handler/app/Handler.hs index 9de6e86ed..efa11b521 100644 --- a/infra/handler/app/Handler.hs +++ b/infra/handler/app/Handler.hs @@ -19,6 +19,6 @@ main = do liftIO $ putStrLn "Booted!" -- TODO: from env - let projectId = ProjectId "my-project-id" + let projectId = ProjectId "deckdeckgo-studio-beta" Lambda.run $ Cors.simpleCors $ DeckGo.Handler.application (env ^. Aws.envManager) projectId env diff --git a/infra/handler/app/Test.hs b/infra/handler/app/Test.hs index 7885fdebc..8f628cf67 100644 --- a/infra/handler/app/Test.hs +++ b/infra/handler/app/Test.hs @@ -25,14 +25,16 @@ main = do Right [] -> pure () Right decks -> error $ "Expected 0 users, got: " <> show decks - runClientM (decksGet' b) clientEnv >>= \case + runClientM (decksGet' b Nothing) clientEnv >>= \case Left err -> error $ "Expected decks, got error: " <> show err Right [] -> pure () Right decks -> error $ "Expected 0 decks, got: " <> show decks - let someDeck = Deck { deckSlides = [] , deckDeckname = Deckname "foo" } + let someUserId = UserId "foo" - deckId <- runClientM (decksPost' someDeck) clientEnv >>= \case + let someDeck = Deck { deckSlides = [] , deckDeckname = Deckname "foo", deckOwnerId = someUserId } + + deckId <- runClientM (decksPost' b someDeck) clientEnv >>= \case Left err -> error $ "Expected new deck, got error: " <> show err Right (WithId deckId _) -> pure deckId @@ -42,13 +44,13 @@ main = do Left err -> error $ "Expected new slide, got error: " <> show err Right (WithId slideId _) -> pure slideId - let newDeck = Deck { deckSlides = [ slideId ], deckDeckname = Deckname "bar" } + let newDeck = Deck { deckSlides = [ slideId ], deckDeckname = Deckname "bar", deckOwnerId = someUserId } runClientM (decksPut' b deckId newDeck) clientEnv >>= \case Left err -> error $ "Expected updated deck, got error: " <> show err Right {} -> pure () - runClientM (decksGet' b) clientEnv >>= \case + runClientM (decksGet' b Nothing) clientEnv >>= \case Left err -> error $ "Expected decks, got error: " <> show err Right decks -> if decks == [WithId deckId newDeck] then pure () else (error $ "Expected updated decks, got: " <> show decks) @@ -92,7 +94,7 @@ main = do Left err -> error $ "Expected deck delete, got error: " <> show err Right {} -> pure () - runClientM (decksGet' b) clientEnv >>= \case + runClientM (decksGet' b Nothing) clientEnv >>= \case Left err -> error $ "Expected no decks, got error: " <> show err Right decks -> if decks == [] then pure () else (error $ "Expected no decks, got: " <> show decks) @@ -104,9 +106,9 @@ _usersPost' :: T.Text -> User -> ClientM (WithId UserId User) _usersPut' :: T.Text -> UserId -> User -> ClientM (WithId UserId User) _usersDelete' :: T.Text -> UserId -> ClientM () -decksGet' :: T.Text -> ClientM [WithId DeckId Deck] +decksGet' :: T.Text -> Maybe UserId -> ClientM [WithId DeckId Deck] decksGetDeckId' :: T.Text -> DeckId -> ClientM (WithId DeckId Deck) -decksPost' :: Deck -> ClientM (WithId DeckId Deck) +decksPost' :: T.Text -> Deck -> ClientM (WithId DeckId Deck) decksPut' :: T.Text -> DeckId -> Deck -> ClientM (WithId DeckId Deck) decksDelete' :: T.Text -> DeckId -> ClientM () diff --git a/infra/handler/src/DeckGo/Handler.hs b/infra/handler/src/DeckGo/Handler.hs index 9b379dd2c..558520c7b 100644 --- a/infra/handler/src/DeckGo/Handler.hs +++ b/infra/handler/src/DeckGo/Handler.hs @@ -53,6 +53,14 @@ data ServerContext = ServerContext { firebaseProjectId :: Firebase.ProjectId } data WithId id a = WithId id a deriving (Show, Eq, Generic) +-- data Item a = Item { itemId :: T.Text, itemContent :: a } + +-- class ToJSONObject a where + -- toJSONObject :: a -> Aeson.Object + + +-- instance ToJSONObject a => Aeson.ToJSON a where + -- USERS type UsersAPI = @@ -71,9 +79,11 @@ newtype Username = Username { unUsername :: T.Text } deriving newtype (Aeson.FromJSON, Aeson.ToJSON) data User = User - { userDecks :: [DeckId] - , userFirebaseId :: FirebaseId -- TODO: enforce uniqueness - , userUsername :: Username + -- { userDecks :: [DeckId] + { userFirebaseId :: FirebaseId -- TODO: enforce uniqueness + -- , userUsername :: Username -- drop for now + , userAnonymous :: Bool + -- isanonymous } deriving (Show, Eq) newtype UserId = UserId { unUserId :: T.Text } @@ -103,39 +113,42 @@ newtype FirebaseId = FirebaseId { unFirebaseId :: T.Text } instance Aeson.FromJSON User where parseJSON = Aeson.withObject "user" $ \obj -> User - <$> obj .: "user_username" - <*> obj .: "user_decks" - <*> obj .: "user_firebaseid" + -- potentially return "error exists" + user object + <$> obj .: "user_firebase_uid" + <*> obj .: "user_anonymous" -- TODO: TTL instance Aeson.ToJSON User where toJSON user = Aeson.object - [ "user_username" .= userUsername user - , "user_decks" .= userDecks user - , "user_firebaseid" .= userFirebaseId user + [ "user_firebase_uid" .= userFirebaseId user -- firebaseid -> firebaseuid + , "user_anonymous" .= userAnonymous user -- firebaseid -> firebaseuid ] +-- TODO: check user is in DB +-- TODO: check permissions +-- TODO: created_at, updated_at + -- TODO: deduplicate those instances instance Aeson.FromJSON (WithId UserId User) where parseJSON = Aeson.withObject "WithId UserId User" $ \o -> WithId <$> (UserId <$> o .: "user_id") <*> - (User <$> o .: "user_decks" <*> o .: "user_username" <*> o .: "user_firebaseid") + (User <$> o .: "user_firebase_uid" <*> o .: "user_anonymous" ) instance Aeson.ToJSON (WithId UserId User) where toJSON (WithId userId user) = Aeson.object [ "user_id" .= userId - , "user_decks" .= userDecks user - , "user_name" .= userUsername user + , "user_firebase_uid" .= userFirebaseId user + , "user_anonymous" .= userAnonymous user ] -- DECKS type DecksAPI = - Protected :> Get '[JSON] [WithId DeckId Deck] :<|> + Protected :> QueryParam "owner_id" UserId :> Get '[JSON] [WithId DeckId Deck] :<|> Protected :> Capture "deck_id" DeckId :> Get '[JSON] (WithId DeckId Deck) :<|> - ReqBody '[JSON] Deck :> Post '[JSON] (WithId DeckId Deck) :<|> --TODO: protect + Protected :> ReqBody '[JSON] Deck :> Post '[JSON] (WithId DeckId Deck) :<|> Protected :> Capture "deck_id" DeckId :> ReqBody '[JSON] Deck :> Put '[JSON] (WithId DeckId Deck) :<|> @@ -151,6 +164,7 @@ newtype Deckname = Deckname { unDeckname :: T.Text } data Deck = Deck { deckSlides :: [SlideId] , deckDeckname :: Deckname -- TODO: enforce uniqueness + , deckOwnerId :: UserId } deriving (Show, Eq) instance Aeson.FromJSON Deck where @@ -158,11 +172,13 @@ instance Aeson.FromJSON Deck where Deck <$> obj .: "deck_slides" <*> obj .: "deck_name" + <*> obj .: "deck_owner_id" instance Aeson.ToJSON Deck where toJSON deck = Aeson.object [ "deck_slides" .= deckSlides deck , "deck_name" .= deckDeckname deck + , "deck_owner_id" .= deckOwnerId deck ] -- TODO: deduplicate those instances @@ -170,13 +186,14 @@ instance Aeson.FromJSON (WithId DeckId Deck) where parseJSON = Aeson.withObject "WithId DeckId Deck" $ \o -> WithId <$> (DeckId <$> o .: "deck_id") <*> - (Deck <$> o .: "deck_slides" <*> o .: "deck_name") + (Deck <$> o .: "deck_slides" <*> o .: "deck_name" <*> o .: "deck_owner_id") instance Aeson.ToJSON (WithId DeckId Deck) where toJSON (WithId deckId deck) = Aeson.object [ "deck_id" .= deckId , "deck_slides" .= deckSlides deck , "deck_name" .= deckDeckname deck + , "deck_owner_id" .= deckOwnerId deck ] -- SLIDES @@ -382,9 +399,16 @@ usersDelete env _ userId = do -- DECKS -decksGet :: Aws.Env -> Firebase.UserId -> Servant.Handler [WithId DeckId Deck] -decksGet env _uid = do - res <- runAWS env $ Aws.send $ DynamoDB.scan "Decks" +decksGet :: Aws.Env -> Firebase.UserId -> Maybe UserId -> Servant.Handler [WithId DeckId Deck] +decksGet env _uid mUserId = do + + let updateReq = case mUserId of + Nothing -> id + Just userId -> \req -> req & + DynamoDB.sFilterExpression .~ Just "DeckOwnerId = :o" & + DynamoDB.sExpressionAttributeValues .~ HMS.singleton ":o" (userIdToAttributeValue userId) + + res <- runAWS env $ Aws.send $ updateReq $ DynamoDB.scan "Decks" case res of Right scanResponse -> case sequence $ scanResponse ^. DynamoDB.srsItems <&> itemToDeck of @@ -422,8 +446,8 @@ decksGetDeckId env _ deckId = do liftIO $ print e Servant.throwError Servant.err500 -decksPost :: Aws.Env -> Deck -> Servant.Handler (WithId DeckId Deck) -decksPost env deck = do +decksPost :: Aws.Env -> Firebase.UserId -> Deck -> Servant.Handler (WithId DeckId Deck) +decksPost env _ deck = do deckId <- liftIO $ DeckId <$> newId @@ -567,24 +591,28 @@ slidesDelete env slideId = do -- USERS userToItem :: UserId -> User -> HMS.HashMap T.Text DynamoDB.AttributeValue -userToItem userId User{userDecks, userUsername, userFirebaseId} = +userToItem userId User{userFirebaseId, userAnonymous} = HMS.singleton "UserId" (userIdToAttributeValue userId) <> - HMS.singleton "UserDecks" (userDecksToAttributeValue userDecks) <> + -- HMS.singleton "UserDecks" (userDecksToAttributeValue userDecks) <> HMS.singleton "UserFirebaseId" (userFirebaseIdToAttributeValue userFirebaseId) <> - HMS.singleton "UserUsername" (userNameToAttributeValue userUsername) + HMS.singleton "UserAnonymous" (userAnonymousToAttributeValue userAnonymous) -- <>B + -- HMS.singleton "UserFirebaseId" (userFirebaseIdToAttributeValue userFirebaseId) <> + -- HMS.singleton "UserUsername" (userNameToAttributeValue userUsername) userToItem' :: User -> HMS.HashMap T.Text DynamoDB.AttributeValue -userToItem' User{userDecks, userUsername, userFirebaseId} = - HMS.singleton ":s" (userDecksToAttributeValue userDecks) <> - HMS.singleton ":i" (userFirebaseIdToAttributeValue userFirebaseId) <> - HMS.singleton ":n" (userNameToAttributeValue userUsername) +userToItem' User{userFirebaseId, userAnonymous} = + -- HMS.singleton ":s" (userDecksToAttributeValue userDecks) <> + HMS.singleton ":i" (userFirebaseIdToAttributeValue userFirebaseId) <> -- <> + HMS.singleton ":a" (userAnonymousToAttributeValue userAnonymous) -- <> + -- HMS.singleton ":n" (userNameToAttributeValue userUsername) itemToUser :: HMS.HashMap T.Text DynamoDB.AttributeValue -> Maybe (WithId UserId User) itemToUser item = do userId <- HMS.lookup "UserId" item >>= userIdFromAttributeValue - userDecks <- HMS.lookup "UserDecks" item >>= userDecksFromAttributeValue - userUsername <- HMS.lookup "UserUsername" item >>= userNameFromAttributeValue + -- userDecks <- HMS.lookup "UserDecks" item >>= userDecksFromAttributeValue + -- userUsername <- HMS.lookup "UserUsername" item >>= userNameFromAttributeValue userFirebaseId <- HMS.lookup "UserFirebaseId" item >>= userFirebaseIdFromAttributeValue + userAnonymous <- HMS.lookup "UserAnonymous" item >>= userAnonymousFromAttributeValue pure $ WithId userId User{..} -- USER ATTRIBUTES @@ -610,6 +638,13 @@ userFirebaseIdToAttributeValue (FirebaseId userId) = userFirebaseIdFromAttributeValue :: DynamoDB.AttributeValue -> Maybe FirebaseId userFirebaseIdFromAttributeValue attr = FirebaseId <$> attr ^. DynamoDB.avS +userAnonymousToAttributeValue :: Bool -> DynamoDB.AttributeValue +userAnonymousToAttributeValue b = + DynamoDB.attributeValue & DynamoDB.avBOOL .~ Just b + +userAnonymousFromAttributeValue :: DynamoDB.AttributeValue -> Maybe Bool +userAnonymousFromAttributeValue attr = attr ^. DynamoDB.avBOOL + userDecksToAttributeValue :: [DeckId] -> DynamoDB.AttributeValue userDecksToAttributeValue userDecks = DynamoDB.attributeValue & DynamoDB.avL .~ @@ -622,21 +657,24 @@ userDecksFromAttributeValue attr = -- DECKS deckToItem :: DeckId -> Deck -> HMS.HashMap T.Text DynamoDB.AttributeValue -deckToItem deckId Deck{deckSlides, deckDeckname} = +deckToItem deckId Deck{deckSlides, deckDeckname, deckOwnerId} = HMS.singleton "DeckId" (deckIdToAttributeValue deckId) <> HMS.singleton "DeckSlides" (deckSlidesToAttributeValue deckSlides) <> - HMS.singleton "DeckName" (deckNameToAttributeValue deckDeckname) + HMS.singleton "DeckName" (deckNameToAttributeValue deckDeckname) <> + HMS.singleton "DeckOwnerId" (deckOwnerIdToAttributeValue deckOwnerId) deckToItem' :: Deck -> HMS.HashMap T.Text DynamoDB.AttributeValue -deckToItem' Deck{deckSlides, deckDeckname} = +deckToItem' Deck{deckSlides, deckDeckname, deckOwnerId} = HMS.singleton ":s" (deckSlidesToAttributeValue deckSlides) <> - HMS.singleton ":n" (deckNameToAttributeValue deckDeckname) + HMS.singleton ":n" (deckNameToAttributeValue deckDeckname) <> + HMS.singleton ":o" (deckOwnerIdToAttributeValue deckOwnerId) itemToDeck :: HMS.HashMap T.Text DynamoDB.AttributeValue -> Maybe (WithId DeckId Deck) itemToDeck item = do deckId <- HMS.lookup "DeckId" item >>= deckIdFromAttributeValue deckSlides <- HMS.lookup "DeckSlides" item >>= deckSlidesFromAttributeValue deckDeckname <- HMS.lookup "DeckName" item >>= deckNameFromAttributeValue + deckOwnerId <- HMS.lookup "DeckOwnerId" item >>= deckOwnerIdFromAttributeValue pure $ WithId deckId Deck{..} -- DECK ATTRIBUTES @@ -645,6 +683,9 @@ deckIdToAttributeValue :: DeckId -> DynamoDB.AttributeValue deckIdToAttributeValue (DeckId deckId) = DynamoDB.attributeValue & DynamoDB.avS .~ Just deckId +deckIdFromAttributeValue :: DynamoDB.AttributeValue -> Maybe DeckId +deckIdFromAttributeValue attr = DeckId <$> attr ^. DynamoDB.avS + deckNameToAttributeValue :: Deckname -> DynamoDB.AttributeValue deckNameToAttributeValue (Deckname deckname) = DynamoDB.attributeValue & DynamoDB.avS .~ Just deckname @@ -652,9 +693,6 @@ deckNameToAttributeValue (Deckname deckname) = deckNameFromAttributeValue :: DynamoDB.AttributeValue -> Maybe Deckname deckNameFromAttributeValue attr = Deckname <$> attr ^. DynamoDB.avS -deckIdFromAttributeValue :: DynamoDB.AttributeValue -> Maybe DeckId -deckIdFromAttributeValue attr = DeckId <$> attr ^. DynamoDB.avS - deckSlidesToAttributeValue :: [SlideId] -> DynamoDB.AttributeValue deckSlidesToAttributeValue deckSlides = DynamoDB.attributeValue & DynamoDB.avL .~ @@ -664,6 +702,13 @@ deckSlidesFromAttributeValue :: DynamoDB.AttributeValue -> Maybe [SlideId] deckSlidesFromAttributeValue attr = traverse slideIdFromAttributeValue (attr ^. DynamoDB.avL) +deckOwnerIdToAttributeValue :: UserId -> DynamoDB.AttributeValue +deckOwnerIdToAttributeValue (UserId deckOwnerId) = + DynamoDB.attributeValue & DynamoDB.avS .~ Just deckOwnerId + +deckOwnerIdFromAttributeValue :: DynamoDB.AttributeValue -> Maybe UserId +deckOwnerIdFromAttributeValue attr = UserId <$> attr ^. DynamoDB.avS + -- SLIDES slideToItem :: SlideId -> Slide -> HMS.HashMap T.Text DynamoDB.AttributeValue From 80bd0f4e21ed81077123cfc58a8e082b89598f52 Mon Sep 17 00:00:00 2001 From: Nicolas Mattia Date: Sat, 6 Apr 2019 14:59:17 +0200 Subject: [PATCH 17/19] handler: deduplicate JSON instances --- infra/handler/app/Test.hs | 38 +++--- infra/handler/src/DeckGo/Handler.hs | 196 ++++++++++++---------------- 2 files changed, 99 insertions(+), 135 deletions(-) diff --git a/infra/handler/app/Test.hs b/infra/handler/app/Test.hs index 8f628cf67..b545e8880 100644 --- a/infra/handler/app/Test.hs +++ b/infra/handler/app/Test.hs @@ -36,13 +36,13 @@ main = do deckId <- runClientM (decksPost' b someDeck) clientEnv >>= \case Left err -> error $ "Expected new deck, got error: " <> show err - Right (WithId deckId _) -> pure deckId + Right (Item deckId _) -> pure deckId let someSlide = Slide "foo" "bar" HMS.empty slideId <- runClientM (slidesPost' someSlide) clientEnv >>= \case Left err -> error $ "Expected new slide, got error: " <> show err - Right (WithId slideId _) -> pure slideId + Right (Item slideId _) -> pure slideId let newDeck = Deck { deckSlides = [ slideId ], deckDeckname = Deckname "bar", deckOwnerId = someUserId } @@ -53,17 +53,17 @@ main = do runClientM (decksGet' b Nothing) clientEnv >>= \case Left err -> error $ "Expected decks, got error: " <> show err Right decks -> - if decks == [WithId deckId newDeck] then pure () else (error $ "Expected updated decks, got: " <> show decks) + if decks == [Item deckId newDeck] then pure () else (error $ "Expected updated decks, got: " <> show decks) runClientM (decksGetDeckId' b deckId) clientEnv >>= \case Left err -> error $ "Expected decks, got error: " <> show err Right deck -> - if deck == (WithId deckId newDeck) then pure () else (error $ "Expected get deck, got: " <> show deck) + if deck == (Item deckId newDeck) then pure () else (error $ "Expected get deck, got: " <> show deck) runClientM slidesGet' clientEnv >>= \case Left err -> error $ "Expected slides, got error: " <> show err Right slides -> - if slides == [WithId slideId someSlide] then pure () else (error $ "Expected slides, got: " <> show slides) + if slides == [Item slideId someSlide] then pure () else (error $ "Expected slides, got: " <> show slides) let updatedSlide = Slide "foo" "quux" HMS.empty @@ -74,12 +74,12 @@ main = do runClientM slidesGet' clientEnv >>= \case Left err -> error $ "Expected updated slides, got error: " <> show err Right slides -> - if slides == [WithId slideId updatedSlide] then pure () else (error $ "Expected updated slides, got: " <> show slides) + if slides == [Item slideId updatedSlide] then pure () else (error $ "Expected updated slides, got: " <> show slides) runClientM (slidesGetSlideId' slideId) clientEnv >>= \case Left err -> error $ "Expected updated slide, got error: " <> show err Right slide -> - if slide == (WithId slideId updatedSlide) then pure () else (error $ "Expected updated slide, got: " <> show slide) + if slide == (Item slideId updatedSlide) then pure () else (error $ "Expected updated slide, got: " <> show slide) runClientM (slidesDelete' slideId) clientEnv >>= \case Left err -> error $ "Expected slide delete, got error: " <> show err @@ -100,22 +100,22 @@ main = do if decks == [] then pure () else (error $ "Expected no decks, got: " <> show decks) -usersGet' :: ClientM [WithId UserId User] -_usersGetUserId' :: UserId -> ClientM (WithId UserId User) -_usersPost' :: T.Text -> User -> ClientM (WithId UserId User) -_usersPut' :: T.Text -> UserId -> User -> ClientM (WithId UserId User) +usersGet' :: ClientM [Item UserId User] +_usersGetUserId' :: UserId -> ClientM (Item UserId User) +_usersPost' :: T.Text -> User -> ClientM (Item UserId User) +_usersPut' :: T.Text -> UserId -> User -> ClientM (Item UserId User) _usersDelete' :: T.Text -> UserId -> ClientM () -decksGet' :: T.Text -> Maybe UserId -> ClientM [WithId DeckId Deck] -decksGetDeckId' :: T.Text -> DeckId -> ClientM (WithId DeckId Deck) -decksPost' :: T.Text -> Deck -> ClientM (WithId DeckId Deck) -decksPut' :: T.Text -> DeckId -> Deck -> ClientM (WithId DeckId Deck) +decksGet' :: T.Text -> Maybe UserId -> ClientM [Item DeckId Deck] +decksGetDeckId' :: T.Text -> DeckId -> ClientM (Item DeckId Deck) +decksPost' :: T.Text -> Deck -> ClientM (Item DeckId Deck) +decksPut' :: T.Text -> DeckId -> Deck -> ClientM (Item DeckId Deck) decksDelete' :: T.Text -> DeckId -> ClientM () -slidesGet' :: ClientM [WithId SlideId Slide] -slidesGetSlideId' :: SlideId -> ClientM (WithId SlideId Slide) -slidesPost' :: Slide -> ClientM (WithId SlideId Slide) -slidesPut' :: SlideId -> Slide -> ClientM (WithId SlideId Slide) +slidesGet' :: ClientM [Item SlideId Slide] +slidesGetSlideId' :: SlideId -> ClientM (Item SlideId Slide) +slidesPost' :: Slide -> ClientM (Item SlideId Slide) +slidesPut' :: SlideId -> Slide -> ClientM (Item SlideId Slide) slidesDelete' :: SlideId -> ClientM () (( usersGet' :<|> diff --git a/infra/handler/src/DeckGo/Handler.hs b/infra/handler/src/DeckGo/Handler.hs index 558520c7b..a23daaeb1 100644 --- a/infra/handler/src/DeckGo/Handler.hs +++ b/infra/handler/src/DeckGo/Handler.hs @@ -30,6 +30,7 @@ import Servant.API import Servant.Auth.Firebase (Protected) import UnliftIO import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson import qualified Data.HashMap.Strict as HMS import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -49,29 +50,35 @@ data ServerContext = ServerContext { firebaseProjectId :: Firebase.ProjectId } -- COMMON - -data WithId id a = WithId id a +data Item id a = Item { itemId :: id, itemContent :: a } deriving (Show, Eq, Generic) --- data Item a = Item { itemId :: T.Text, itemContent :: a } +class ToJSONObject a where + toJSONObject :: a -> Aeson.Object --- class ToJSONObject a where - -- toJSONObject :: a -> Aeson.Object +instance (Aeson.ToJSON id, ToJSONObject a) => Aeson.ToJSON (Item id a) where + toJSON i = Aeson.Object $ + HMS.fromList [ "id" .= itemId i ] <> + toJSONObject (itemContent i) +class FromJSONObject a where + parseJSONObject :: Aeson.Object -> Aeson.Parser a --- instance ToJSONObject a => Aeson.ToJSON a where +instance (Aeson.FromJSON id, FromJSONObject a) => Aeson.FromJSON (Item id a) where + parseJSON = Aeson.withObject "FromJSONObject" $ \o -> Item <$> + o .: "id" <*> parseJSONObject o -- USERS type UsersAPI = - Get '[JSON] [WithId UserId User] :<|> - Capture "user_id" UserId :> Get '[JSON] (WithId UserId User) :<|> + Get '[JSON] [Item UserId User] :<|> + Capture "user_id" UserId :> Get '[JSON] (Item UserId User) :<|> Protected :> ReqBody '[JSON] User :> - Post '[JSON] (WithId UserId User) :<|> + Post '[JSON] (Item UserId User) :<|> Protected :> Capture "user_id" UserId :> - ReqBody '[JSON] User :> Put '[JSON] (WithId UserId User) :<|> + ReqBody '[JSON] User :> Put '[JSON] (Item UserId User) :<|> Protected :> Capture "user_id" UserId :> Delete '[JSON] () newtype Username = Username { unUsername :: T.Text } @@ -79,11 +86,8 @@ newtype Username = Username { unUsername :: T.Text } deriving newtype (Aeson.FromJSON, Aeson.ToJSON) data User = User - -- { userDecks :: [DeckId] { userFirebaseId :: FirebaseId -- TODO: enforce uniqueness - -- , userUsername :: Username -- drop for now , userAnonymous :: Bool - -- isanonymous } deriving (Show, Eq) newtype UserId = UserId { unUserId :: T.Text } @@ -110,48 +114,38 @@ newtype FirebaseId = FirebaseId { unFirebaseId :: T.Text } deriving stock ( Generic ) -instance Aeson.FromJSON User where - parseJSON = Aeson.withObject "user" $ \obj -> +instance FromJSONObject User where + parseJSONObject = \obj -> User -- potentially return "error exists" + user object <$> obj .: "user_firebase_uid" <*> obj .: "user_anonymous" -- TODO: TTL -instance Aeson.ToJSON User where - toJSON user = Aeson.object - [ "user_firebase_uid" .= userFirebaseId user -- firebaseid -> firebaseuid - , "user_anonymous" .= userAnonymous user -- firebaseid -> firebaseuid +instance ToJSONObject User where + toJSONObject user = HMS.fromList + [ "user_firebase_uid" .= userFirebaseId user + , "user_anonymous" .= userAnonymous user ] +instance Aeson.FromJSON User where + parseJSON = Aeson.withObject "User" parseJSONObject +instance Aeson.ToJSON User where + toJSON = Aeson.Object . toJSONObject -- TODO: check user is in DB -- TODO: check permissions -- TODO: created_at, updated_at --- TODO: deduplicate those instances -instance Aeson.FromJSON (WithId UserId User) where - parseJSON = Aeson.withObject "WithId UserId User" $ \o -> - WithId <$> - (UserId <$> o .: "user_id") <*> - (User <$> o .: "user_firebase_uid" <*> o .: "user_anonymous" ) - -instance Aeson.ToJSON (WithId UserId User) where - toJSON (WithId userId user) = Aeson.object - [ "user_id" .= userId - , "user_firebase_uid" .= userFirebaseId user - , "user_anonymous" .= userAnonymous user - ] - -- DECKS type DecksAPI = - Protected :> QueryParam "owner_id" UserId :> Get '[JSON] [WithId DeckId Deck] :<|> + Protected :> QueryParam "owner_id" UserId :> Get '[JSON] [Item DeckId Deck] :<|> Protected :> Capture "deck_id" DeckId :> - Get '[JSON] (WithId DeckId Deck) :<|> - Protected :> ReqBody '[JSON] Deck :> Post '[JSON] (WithId DeckId Deck) :<|> + Get '[JSON] (Item DeckId Deck) :<|> + Protected :> ReqBody '[JSON] Deck :> Post '[JSON] (Item DeckId Deck) :<|> Protected :> Capture "deck_id" DeckId :> - ReqBody '[JSON] Deck :> Put '[JSON] (WithId DeckId Deck) :<|> + ReqBody '[JSON] Deck :> Put '[JSON] (Item DeckId Deck) :<|> Protected :> Capture "deck_id" DeckId :> Delete '[JSON] () newtype DeckId = DeckId { unDeckId :: T.Text } @@ -167,51 +161,41 @@ data Deck = Deck , deckOwnerId :: UserId } deriving (Show, Eq) -instance Aeson.FromJSON Deck where - parseJSON = Aeson.withObject "deck" $ \obj -> +instance FromJSONObject Deck where + parseJSONObject = \obj -> Deck <$> obj .: "deck_slides" <*> obj .: "deck_name" <*> obj .: "deck_owner_id" -instance Aeson.ToJSON Deck where - toJSON deck = Aeson.object +instance ToJSONObject Deck where + toJSONObject deck = HMS.fromList [ "deck_slides" .= deckSlides deck , "deck_name" .= deckDeckname deck , "deck_owner_id" .= deckOwnerId deck ] --- TODO: deduplicate those instances -instance Aeson.FromJSON (WithId DeckId Deck) where - parseJSON = Aeson.withObject "WithId DeckId Deck" $ \o -> - WithId <$> - (DeckId <$> o .: "deck_id") <*> - (Deck <$> o .: "deck_slides" <*> o .: "deck_name" <*> o .: "deck_owner_id") - -instance Aeson.ToJSON (WithId DeckId Deck) where - toJSON (WithId deckId deck) = Aeson.object - [ "deck_id" .= deckId - , "deck_slides" .= deckSlides deck - , "deck_name" .= deckDeckname deck - , "deck_owner_id" .= deckOwnerId deck - ] +instance Aeson.FromJSON Deck where + parseJSON = Aeson.withObject "Deck" parseJSONObject +instance Aeson.ToJSON Deck where + toJSON = Aeson.Object . toJSONObject -- SLIDES type SlidesAPI = - Get '[JSON] [WithId SlideId Slide] :<|> - Capture "slide_id" SlideId :> Get '[JSON] (WithId SlideId Slide) :<|> - ReqBody '[JSON] Slide :> Post '[JSON] (WithId SlideId Slide) :<|> - Capture "slide_id" SlideId :> ReqBody '[JSON] Slide :> Put '[JSON] (WithId SlideId Slide) :<|> + Get '[JSON] [Item SlideId Slide] :<|> + Capture "slide_id" SlideId :> Get '[JSON] (Item SlideId Slide) :<|> + ReqBody '[JSON] Slide :> Post '[JSON] (Item SlideId Slide) :<|> + Capture "slide_id" SlideId :> ReqBody '[JSON] Slide :> Put '[JSON] (Item SlideId Slide) :<|> Capture "slide_id" SlideId :> Delete '[JSON] () -instance ToSchema (WithId SlideId Slide) where +instance ToSchema (Item SlideId Slide) where declareNamedSchema _ = pure $ NamedSchema (Just "SlideWithId") mempty instance ToSchema Slide where declareNamedSchema _ = pure $ NamedSchema (Just "Slide") mempty -instance ToParamSchema (WithId SlideId Slide) where +instance ToParamSchema (Item SlideId Slide) where toParamSchema _ = mempty newtype SlideId = SlideId { unSlideId :: T.Text } @@ -234,37 +218,24 @@ data Slide = Slide , slideAttributes :: HMS.HashMap T.Text T.Text } deriving (Show, Eq) -instance Aeson.FromJSON Slide where - parseJSON = Aeson.withObject "slide" $ \obj -> +instance FromJSONObject Slide where + parseJSONObject = \obj -> Slide <$> obj .: "slide_content" <*> obj .: "slide_template" <*> obj .:? "slide_attributes" .!= HMS.empty -instance Aeson.ToJSON Slide where - toJSON slide = Aeson.object +instance ToJSONObject Slide where + toJSONObject slide = HMS.fromList [ "slide_template" .= slideTemplate slide , "slide_attributes" .= slideAttributes slide , "slide_content" .= slideContent slide ] -instance Aeson.FromJSON (WithId SlideId Slide) where - parseJSON = Aeson.withObject "WithId SlideId Slide" $ \o -> - WithId <$> - (SlideId <$> o .: "slide_id") <*> - (Slide <$> - o .: "slide_content" <*> - o .: "slide_template" <*> - o .: "slide_attributes" - ) - -instance Aeson.ToJSON (WithId SlideId Slide) where - toJSON (WithId slideId slide) = Aeson.object - [ "slide_id" .= slideId - , "slide_template" .= slideTemplate slide - , "slide_attributes" .= slideAttributes slide - , "slide_content" .= slideContent slide - ] +instance Aeson.FromJSON Slide where + parseJSON = Aeson.withObject "Slide" parseJSONObject +instance Aeson.ToJSON Slide where + toJSON = Aeson.Object . toJSONObject type API = "users" :> UsersAPI :<|> @@ -309,7 +280,7 @@ server env = serveUsers :<|> serveDecks :<|> serveSlides -- USERS -usersGet :: Aws.Env -> Servant.Handler [WithId UserId User] +usersGet :: Aws.Env -> Servant.Handler [Item UserId User] usersGet env = do res <- runAWS env $ Aws.send $ DynamoDB.scan "Users" case res of @@ -323,7 +294,7 @@ usersGet env = do liftIO $ print e Servant.throwError Servant.err500 -usersGetUserId :: Aws.Env -> UserId -> Servant.Handler (WithId UserId User) +usersGetUserId :: Aws.Env -> UserId -> Servant.Handler (Item UserId User) usersGetUserId env userId = do res <- runAWS env $ Aws.send $ DynamoDB.getItem "Users" & DynamoDB.giKey .~ HMS.singleton "UserId" (userIdToAttributeValue userId) @@ -349,7 +320,7 @@ usersGetUserId env userId = do liftIO $ print e Servant.throwError Servant.err500 -usersPost :: Aws.Env -> Firebase.UserId -> User -> Servant.Handler (WithId UserId User) +usersPost :: Aws.Env -> Firebase.UserId -> User -> Servant.Handler (Item UserId User) usersPost env _uid user = do userId <- liftIO $ UserId <$> newId @@ -363,9 +334,9 @@ usersPost env _uid user = do liftIO $ print e Servant.throwError Servant.err500 - pure $ WithId userId user + pure $ Item userId user -usersPut :: Aws.Env -> Firebase.UserId -> UserId -> User -> Servant.Handler (WithId UserId User) +usersPut :: Aws.Env -> Firebase.UserId -> UserId -> User -> Servant.Handler (Item UserId User) usersPut env _ userId user = do res <- runAWS env $ Aws.send $ DynamoDB.updateItem "Users" & @@ -382,7 +353,7 @@ usersPut env _ userId user = do liftIO $ print e Servant.throwError Servant.err500 - pure $ WithId userId user + pure $ Item userId user usersDelete :: Aws.Env -> Firebase.UserId -> UserId -> Servant.Handler () usersDelete env _ userId = do @@ -399,7 +370,7 @@ usersDelete env _ userId = do -- DECKS -decksGet :: Aws.Env -> Firebase.UserId -> Maybe UserId -> Servant.Handler [WithId DeckId Deck] +decksGet :: Aws.Env -> Firebase.UserId -> Maybe UserId -> Servant.Handler [Item DeckId Deck] decksGet env _uid mUserId = do let updateReq = case mUserId of @@ -420,7 +391,7 @@ decksGet env _uid mUserId = do liftIO $ print e Servant.throwError Servant.err500 -decksGetDeckId :: Aws.Env -> Firebase.UserId -> DeckId -> Servant.Handler (WithId DeckId Deck) +decksGetDeckId :: Aws.Env -> Firebase.UserId -> DeckId -> Servant.Handler (Item DeckId Deck) decksGetDeckId env _ deckId = do res <- runAWS env $ Aws.send $ DynamoDB.getItem "Decks" & DynamoDB.giKey .~ HMS.singleton "DeckId" (deckIdToAttributeValue deckId) @@ -446,7 +417,7 @@ decksGetDeckId env _ deckId = do liftIO $ print e Servant.throwError Servant.err500 -decksPost :: Aws.Env -> Firebase.UserId -> Deck -> Servant.Handler (WithId DeckId Deck) +decksPost :: Aws.Env -> Firebase.UserId -> Deck -> Servant.Handler (Item DeckId Deck) decksPost env _ deck = do deckId <- liftIO $ DeckId <$> newId @@ -460,13 +431,13 @@ decksPost env _ deck = do liftIO $ print e Servant.throwError Servant.err500 - pure $ WithId deckId deck + pure $ Item deckId deck -decksPut :: Aws.Env -> Firebase.UserId -> DeckId -> Deck -> Servant.Handler (WithId DeckId Deck) +decksPut :: Aws.Env -> Firebase.UserId -> DeckId -> Deck -> Servant.Handler (Item DeckId Deck) decksPut env _ deckId deck = do res <- runAWS env $ Aws.send $ DynamoDB.updateItem "Decks" & - DynamoDB.uiUpdateExpression .~ Just "SET DeckSlides = :s, DeckName = :n" & + DynamoDB.uiUpdateExpression .~ Just "SET DeckSlides = :s, DeckName = :n, DeckOwnerId = :o" & DynamoDB.uiExpressionAttributeValues .~ deckToItem' deck & DynamoDB.uiReturnValues .~ Just DynamoDB.UpdatedNew & DynamoDB.uiKey .~ HMS.singleton "DeckId" @@ -478,7 +449,7 @@ decksPut env _ deckId deck = do liftIO $ print e Servant.throwError Servant.err500 - pure $ WithId deckId deck + pure $ Item deckId deck decksDelete :: Aws.Env -> Firebase.UserId -> DeckId -> Servant.Handler () decksDelete env _ deckId = do @@ -495,7 +466,7 @@ decksDelete env _ deckId = do -- SLIDES -slidesGet :: Aws.Env -> Servant.Handler [WithId SlideId Slide] +slidesGet :: Aws.Env -> Servant.Handler [Item SlideId Slide] slidesGet env = do res <- runAWS env $ Aws.send $ DynamoDB.scan "Slides" case res of @@ -510,7 +481,7 @@ slidesGet env = do liftIO $ print e Servant.throwError Servant.err500 -slidesGetSlideId :: Aws.Env -> SlideId -> Servant.Handler (WithId SlideId Slide) +slidesGetSlideId :: Aws.Env -> SlideId -> Servant.Handler (Item SlideId Slide) slidesGetSlideId env slideId = do res <- runAWS env $ Aws.send $ DynamoDB.getItem "Slides" & DynamoDB.giKey .~ HMS.singleton "SlideId" (slideIdToAttributeValue slideId) @@ -536,7 +507,7 @@ slidesGetSlideId env slideId = do liftIO $ print e Servant.throwError Servant.err500 -slidesPost :: Aws.Env -> Slide -> Servant.Handler (WithId SlideId Slide) +slidesPost :: Aws.Env -> Slide -> Servant.Handler (Item SlideId Slide) slidesPost env slide = do slideId <- liftIO $ SlideId <$> newId @@ -550,9 +521,9 @@ slidesPost env slide = do liftIO $ print e Servant.throwError Servant.err500 - pure $ WithId slideId slide + pure $ Item slideId slide -slidesPut :: Aws.Env -> SlideId -> Slide -> Servant.Handler (WithId SlideId Slide) +slidesPut :: Aws.Env -> SlideId -> Slide -> Servant.Handler (Item SlideId Slide) slidesPut env slideId slide = do res <- runAWS env $ Aws.send $ DynamoDB.updateItem "Slides" & @@ -569,7 +540,7 @@ slidesPut env slideId slide = do liftIO $ print e Servant.throwError Servant.err500 - pure $ WithId slideId slide + pure $ Item slideId slide slidesDelete :: Aws.Env -> SlideId -> Servant.Handler () slidesDelete env slideId = do @@ -593,27 +564,20 @@ slidesDelete env slideId = do userToItem :: UserId -> User -> HMS.HashMap T.Text DynamoDB.AttributeValue userToItem userId User{userFirebaseId, userAnonymous} = HMS.singleton "UserId" (userIdToAttributeValue userId) <> - -- HMS.singleton "UserDecks" (userDecksToAttributeValue userDecks) <> HMS.singleton "UserFirebaseId" (userFirebaseIdToAttributeValue userFirebaseId) <> HMS.singleton "UserAnonymous" (userAnonymousToAttributeValue userAnonymous) -- <>B - -- HMS.singleton "UserFirebaseId" (userFirebaseIdToAttributeValue userFirebaseId) <> - -- HMS.singleton "UserUsername" (userNameToAttributeValue userUsername) userToItem' :: User -> HMS.HashMap T.Text DynamoDB.AttributeValue userToItem' User{userFirebaseId, userAnonymous} = - -- HMS.singleton ":s" (userDecksToAttributeValue userDecks) <> - HMS.singleton ":i" (userFirebaseIdToAttributeValue userFirebaseId) <> -- <> - HMS.singleton ":a" (userAnonymousToAttributeValue userAnonymous) -- <> - -- HMS.singleton ":n" (userNameToAttributeValue userUsername) + HMS.singleton ":i" (userFirebaseIdToAttributeValue userFirebaseId) <> + HMS.singleton ":a" (userAnonymousToAttributeValue userAnonymous) -itemToUser :: HMS.HashMap T.Text DynamoDB.AttributeValue -> Maybe (WithId UserId User) +itemToUser :: HMS.HashMap T.Text DynamoDB.AttributeValue -> Maybe (Item UserId User) itemToUser item = do userId <- HMS.lookup "UserId" item >>= userIdFromAttributeValue - -- userDecks <- HMS.lookup "UserDecks" item >>= userDecksFromAttributeValue - -- userUsername <- HMS.lookup "UserUsername" item >>= userNameFromAttributeValue userFirebaseId <- HMS.lookup "UserFirebaseId" item >>= userFirebaseIdFromAttributeValue userAnonymous <- HMS.lookup "UserAnonymous" item >>= userAnonymousFromAttributeValue - pure $ WithId userId User{..} + pure $ Item userId User{..} -- USER ATTRIBUTES @@ -669,13 +633,13 @@ deckToItem' Deck{deckSlides, deckDeckname, deckOwnerId} = HMS.singleton ":n" (deckNameToAttributeValue deckDeckname) <> HMS.singleton ":o" (deckOwnerIdToAttributeValue deckOwnerId) -itemToDeck :: HMS.HashMap T.Text DynamoDB.AttributeValue -> Maybe (WithId DeckId Deck) +itemToDeck :: HMS.HashMap T.Text DynamoDB.AttributeValue -> Maybe (Item DeckId Deck) itemToDeck item = do deckId <- HMS.lookup "DeckId" item >>= deckIdFromAttributeValue deckSlides <- HMS.lookup "DeckSlides" item >>= deckSlidesFromAttributeValue deckDeckname <- HMS.lookup "DeckName" item >>= deckNameFromAttributeValue deckOwnerId <- HMS.lookup "DeckOwnerId" item >>= deckOwnerIdFromAttributeValue - pure $ WithId deckId Deck{..} + pure $ Item deckId Deck{..} -- DECK ATTRIBUTES @@ -724,7 +688,7 @@ slideToItem' Slide{slideContent, slideTemplate, slideAttributes} = HMS.singleton ":t" (slideTemplateToAttributeValue slideTemplate) <> HMS.singleton ":a" (slideAttributesToAttributeValue slideAttributes) -itemToSlide :: HMS.HashMap T.Text DynamoDB.AttributeValue -> Maybe (WithId SlideId Slide) +itemToSlide :: HMS.HashMap T.Text DynamoDB.AttributeValue -> Maybe (Item SlideId Slide) itemToSlide item = do slideId <- HMS.lookup "SlideId" item >>= slideIdFromAttributeValue @@ -733,7 +697,7 @@ itemToSlide item = do slideTemplate <- HMS.lookup "SlideTemplate" item >>= slideTemplateFromAttributeValue slideAttributes <- HMS.lookup "SlideAttributes" item >>= slideAttributesFromAttributeValue - pure $ WithId slideId Slide{..} + pure $ Item slideId Slide{..} -- SLIDE ATTRIBUTES From b3d0b3210c6d8f1e7b2e91674c8f894e00de2245 Mon Sep 17 00:00:00 2001 From: Nicolas Mattia Date: Sat, 6 Apr 2019 15:00:31 +0200 Subject: [PATCH 18/19] handler: drop JSON object prefixes --- infra/handler/src/DeckGo/Handler.hs | 34 ++++++++++++++--------------- 1 file changed, 17 insertions(+), 17 deletions(-) diff --git a/infra/handler/src/DeckGo/Handler.hs b/infra/handler/src/DeckGo/Handler.hs index a23daaeb1..03fc989c3 100644 --- a/infra/handler/src/DeckGo/Handler.hs +++ b/infra/handler/src/DeckGo/Handler.hs @@ -118,13 +118,13 @@ instance FromJSONObject User where parseJSONObject = \obj -> User -- potentially return "error exists" + user object - <$> obj .: "user_firebase_uid" - <*> obj .: "user_anonymous" -- TODO: TTL + <$> obj .: "firebase_uid" + <*> obj .: "anonymous" -- TODO: TTL instance ToJSONObject User where toJSONObject user = HMS.fromList - [ "user_firebase_uid" .= userFirebaseId user - , "user_anonymous" .= userAnonymous user + [ "firebase_uid" .= userFirebaseId user + , "anonymous" .= userAnonymous user ] instance Aeson.FromJSON User where @@ -164,15 +164,15 @@ data Deck = Deck instance FromJSONObject Deck where parseJSONObject = \obj -> Deck - <$> obj .: "deck_slides" - <*> obj .: "deck_name" - <*> obj .: "deck_owner_id" + <$> obj .: "slides" + <*> obj .: "name" + <*> obj .: "owner_id" instance ToJSONObject Deck where toJSONObject deck = HMS.fromList - [ "deck_slides" .= deckSlides deck - , "deck_name" .= deckDeckname deck - , "deck_owner_id" .= deckOwnerId deck + [ "slides" .= deckSlides deck + , "name" .= deckDeckname deck + , "owner_id" .= deckOwnerId deck ] instance Aeson.FromJSON Deck where @@ -221,15 +221,15 @@ data Slide = Slide instance FromJSONObject Slide where parseJSONObject = \obj -> Slide <$> - obj .: "slide_content" <*> - obj .: "slide_template" <*> - obj .:? "slide_attributes" .!= HMS.empty + obj .: "content" <*> + obj .: "template" <*> + obj .:? "attributes" .!= HMS.empty instance ToJSONObject Slide where toJSONObject slide = HMS.fromList - [ "slide_template" .= slideTemplate slide - , "slide_attributes" .= slideAttributes slide - , "slide_content" .= slideContent slide + [ "template" .= slideTemplate slide + , "attributes" .= slideAttributes slide + , "content" .= slideContent slide ] instance Aeson.FromJSON Slide where @@ -565,7 +565,7 @@ userToItem :: UserId -> User -> HMS.HashMap T.Text DynamoDB.AttributeValue userToItem userId User{userFirebaseId, userAnonymous} = HMS.singleton "UserId" (userIdToAttributeValue userId) <> HMS.singleton "UserFirebaseId" (userFirebaseIdToAttributeValue userFirebaseId) <> - HMS.singleton "UserAnonymous" (userAnonymousToAttributeValue userAnonymous) -- <>B + HMS.singleton "UserAnonymous" (userAnonymousToAttributeValue userAnonymous) userToItem' :: User -> HMS.HashMap T.Text DynamoDB.AttributeValue userToItem' User{userFirebaseId, userAnonymous} = From 66c9dcf7c344e369a27fd60fb4af5d279cd81f19 Mon Sep 17 00:00:00 2001 From: Nicolas Mattia Date: Sat, 6 Apr 2019 15:19:04 +0200 Subject: [PATCH 19/19] handler: swagger the whole API --- infra/firebase-login/package.yaml | 1 + .../src/Servant/Auth/Firebase.hs | 4 +++ infra/handler/app/Swagger.hs | 2 +- infra/handler/src/DeckGo/Handler.hs | 34 ++++++++++++++++--- 4 files changed, 36 insertions(+), 5 deletions(-) diff --git a/infra/firebase-login/package.yaml b/infra/firebase-login/package.yaml index b10e906f2..fb0b4768f 100644 --- a/infra/firebase-login/package.yaml +++ b/infra/firebase-login/package.yaml @@ -18,6 +18,7 @@ dependencies: - servant - servant-client-core - servant-server + - servant-swagger - text - unordered-containers - wai diff --git a/infra/firebase-login/src/Servant/Auth/Firebase.hs b/infra/firebase-login/src/Servant/Auth/Firebase.hs index 1108dac83..715e5b952 100644 --- a/infra/firebase-login/src/Servant/Auth/Firebase.hs +++ b/infra/firebase-login/src/Servant/Auth/Firebase.hs @@ -17,6 +17,7 @@ import Control.Monad.Except import Data.Proxy import Data.Word8 (isSpace, toLower) import Servant.API +import qualified Servant.Swagger as Servant import qualified Crypto.JOSE.JWK as JWK import qualified Network.URI as URI import qualified Crypto.JWT as JWT @@ -154,3 +155,6 @@ instance hoistServerWithContext Proxy p hoist s = \uid -> Servant.hoistServerWithContext (Proxy :: Proxy sub) p hoist (s uid) + +instance Servant.HasSwagger sub => Servant.HasSwagger (Protected :> sub) where + toSwagger Proxy = Servant.toSwagger (Proxy :: Proxy sub) diff --git a/infra/handler/app/Swagger.hs b/infra/handler/app/Swagger.hs index f8095faac..fc23b6a13 100644 --- a/infra/handler/app/Swagger.hs +++ b/infra/handler/app/Swagger.hs @@ -26,7 +26,7 @@ swagger :: Swagger.Swagger swagger = Servant.toSwagger (Proxy :: Proxy DeckGo.Handler.SlidesAPI) dumpSwagger :: FilePath -> IO () -dumpSwagger out = Servant.swaggerSchemaUiDump out swaggerApi (Proxy :: Proxy DeckGo.Handler.SlidesAPI) +dumpSwagger out = Servant.swaggerSchemaUiDump out swaggerApi DeckGo.Handler.api serveSwagger :: IO () serveSwagger = diff --git a/infra/handler/src/DeckGo/Handler.hs b/infra/handler/src/DeckGo/Handler.hs index 03fc989c3..75b01f507 100644 --- a/infra/handler/src/DeckGo/Handler.hs +++ b/infra/handler/src/DeckGo/Handler.hs @@ -17,6 +17,10 @@ module DeckGo.Handler where -- TODO: double check what is returned on 200 from DynamoDB +-- TODO: check user is in DB +-- TODO: check permissions +-- TODO: created_at, updated_at +-- TODO: TTL on anonymous users import Control.Lens hiding ((.=)) import Control.Monad @@ -119,7 +123,7 @@ instance FromJSONObject User where User -- potentially return "error exists" + user object <$> obj .: "firebase_uid" - <*> obj .: "anonymous" -- TODO: TTL + <*> obj .: "anonymous" instance ToJSONObject User where toJSONObject user = HMS.fromList @@ -131,9 +135,19 @@ instance Aeson.FromJSON User where parseJSON = Aeson.withObject "User" parseJSONObject instance Aeson.ToJSON User where toJSON = Aeson.Object . toJSONObject --- TODO: check user is in DB --- TODO: check permissions --- TODO: created_at, updated_at + + +instance ToSchema (Item UserId User) where + declareNamedSchema _ = pure $ NamedSchema (Just "UserWithId") mempty + +instance ToSchema User where + declareNamedSchema _ = pure $ NamedSchema (Just "User") mempty + +instance ToParamSchema (Item UserId User) where + toParamSchema _ = mempty + +instance ToParamSchema UserId where + toParamSchema _ = mempty -- DECKS @@ -180,6 +194,18 @@ instance Aeson.FromJSON Deck where instance Aeson.ToJSON Deck where toJSON = Aeson.Object . toJSONObject +instance ToSchema (Item DeckId Deck) where + declareNamedSchema _ = pure $ NamedSchema (Just "DeckWithId") mempty + +instance ToSchema Deck where + declareNamedSchema _ = pure $ NamedSchema (Just "Deck") mempty + +instance ToParamSchema (Item DeckId Deck) where + toParamSchema _ = mempty + +instance ToParamSchema DeckId where + toParamSchema _ = mempty + -- SLIDES type SlidesAPI =