commit cbf619c3708d7184d18437072b364fd4f2f6e3c3 Author: Saku Laesvuori Date: Fri Jan 20 09:20:06 2023 +0200 Initial commit diff --git a/Client.hs b/Client.hs new file mode 100644 index 0000000..b5b3423 --- /dev/null +++ b/Client.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ViewPatterns #-} + +{-# LANGUAGE NoImplicitPrelude #-} + +import Relude hiding (get) + +import Yesod +import Yesod.Auth +import Client.Types +import Client.Handlers +import Client.Auth () +import Yesod.Static (static, Static) +import System.Directory (createDirectoryIfMissing) + +mkYesodDispatch "DataIdClient" resourcesDataIdClient + +main :: IO () +main = getStaticDir "/tmp/data-id" >>= warp 3000 . DataIdClient + +getStaticDir :: FilePath -> IO Static +getStaticDir dir = createDirectoryIfMissing True dir >> static dir diff --git a/Client/ApiRequests.hs b/Client/ApiRequests.hs new file mode 100644 index 0000000..b17df29 --- /dev/null +++ b/Client/ApiRequests.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +{-# LANGUAGE NoImplicitPrelude #-} + +module Client.ApiRequests where + +import Relude + +import Data.Morpheus.Client +import Yesod hiding (Header) +import Yesod.Auth + +type ClientTypeConstraint (a :: Type) = (RequestType a, ToJSON (RequestArgs a), FromJSON a) +-- From Data.Morpheus.Client.Fetch.RequestType +type Header = (Text, Text) +-- From Data.Morpheus.Client.Fetch.GQLClient +-- No clue why these are not exported + +type RequestConstraint a site = (ClientTypeConstraint a, ApiRequest site) + +type Authorization = Text + +class YesodAuth site => ApiRequest site where + getApiUrl :: HandlerFor site Text + authIdToAuthorization :: site -> AuthId site -> Authorization + +apiRequest' :: RequestConstraint a site => [Header] -> Bool -> Args a -> HandlerFor site a +apiRequest' extraHeaders authRequired args = do + yesod <- liftHandler getYesod + auth <- fmap (authIdToAuthorization yesod) <$> if authRequired then Just <$> requireAuthId else maybeAuthId + apiRequestAuth extraHeaders (("Bearer " <>) <$> auth) args >>= handleErrors + +apiRequestAuth :: RequestConstraint a site => + [Header] -> Maybe Authorization -> Args a -> HandlerFor site (GQLClientResult a) +apiRequestAuth extraHeaders auth args = do + apiUrl <- getApiUrl + stream <- liftIO $ request (fromString (toString apiUrl) `withHeaders` headers) args + single stream + where headers = maybe [] (\x -> [("Authorization", x)]) auth <> extraHeaders + +apiRequest :: RequestConstraint a site => Bool -> Args a -> HandlerFor site a +apiRequest authRequired = apiRequest' [] authRequired + +handleErrors :: RequestConstraint a site => GQLClientResult a -> HandlerFor site a +handleErrors (Right a) = pure a +handleErrors (Left (FetchErrorParseFailure s)) = error $ "GQL parse failure: " <> toText s +handleErrors (Left (FetchErrorProducedErrors errs Nothing)) = error $ "GQL errors: " <> show errs +handleErrors (Left (FetchErrorProducedErrors _ (Just a))) = pure a -- TODO log the errors? +handleErrors (Left (FetchErrorNoResult)) = error $ "GQL no results" diff --git a/Client/Auth.hs b/Client/Auth.hs new file mode 100644 index 0000000..470e509 --- /dev/null +++ b/Client/Auth.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-# LANGUAGE NoImplicitPrelude #-} + +module Client.Auth where + +import Relude + +import Server.Types +import Data.Morpheus.Client +import Yesod +import Yesod.Auth +import qualified Data.ByteString.Base64 as B64 (encode) +import qualified Yesod.Auth.Message as Msg + +pluginName = "externalBasic" + +loginR = PluginR pluginName ["login"] + +type Authorization = Text +type CredsIdent = Text + +postLoginR :: YesodAuth master => + (Authorization -> HandlerFor master (Maybe CredsIdent)) -> AuthHandler master TypedContent +postLoginR authReq = do + res <- runInputPostResult $ (\x y -> x <> ":" <> y) + <$> ireq textField "email" <*> ireq textField "password" + case res of + FormSuccess auth -> do + maybeAuth <- liftHandler $ authReq $ ("Basic " <> ) $ decodeUtf8 $ B64.encode $ encodeUtf8 auth + case maybeAuth of + Nothing -> loginErrorMessageI LoginR Msg.NoIdentifierProvided -- invalid creds + Just txt -> do + setCredsRedirect Creds {credsPlugin = pluginName, credsIdent = txt, credsExtra = []} + _ -> loginErrorMessageI LoginR Msg.NoIdentifierProvided + +authExternalBasic :: forall site. YesodAuth site => + (Authorization -> HandlerFor site (Maybe CredsIdent)) -> AuthPlugin site +authExternalBasic authReq = AuthPlugin pluginName dispatch loginForm + where dispatch :: YesodAuth site => Text -> [Text] -> AuthHandler site TypedContent + dispatch "POST" ["login"] = postLoginR authReq >>= sendResponse + dispatch _ _ = notFound + +loginForm :: YesodAuth site => (Route Auth -> Route site) -> WidgetFor site () +loginForm toParent = do + emailId <- newIdent + passwordId <- newIdent + [whamlet| +

Kirjaudu +
+