From c86ab331cc388c4d2d2958d64cb3f4c0bcf47cdb Mon Sep 17 00:00:00 2001 From: nek0 Date: Sun, 8 Sep 2019 12:48:57 +0200 Subject: [PATCH] git vomit --- matebeamter.cabal | 12 +++++++++ src/API.hs | 2 ++ src/AuthUtil.hs | 13 +++++++++ src/Client.hs | 64 +++++++++++++++++++++++++++++++++++++++++++++ src/Control.hs | 6 +++++ src/Control/Auth.hs | 12 +++++++++ src/Control/User.hs | 34 ++++++++++++++++++++++++ src/Main.hs | 24 ++++++++++++----- src/Model.hs | 5 ++++ src/Model/Auth.hs | 3 +++ src/Model/User.hs | 7 +++++ src/Types.hs | 1 + src/Types/Reader.hs | 13 +++++++++ src/View.hs | 1 + src/View/User.hs | 12 +++++++++ 15 files changed, 203 insertions(+), 6 deletions(-) create mode 100644 src/AuthUtil.hs create mode 100644 src/Client.hs create mode 100644 src/Control.hs create mode 100644 src/Control/Auth.hs create mode 100644 src/Control/User.hs create mode 100644 src/Model.hs create mode 100644 src/Model/Auth.hs create mode 100644 src/Model/User.hs create mode 100644 src/Types/Reader.hs create mode 100644 src/View/User.hs diff --git a/matebeamter.cabal b/matebeamter.cabal index 52b7dcd..a53815b 100644 --- a/matebeamter.cabal +++ b/matebeamter.cabal @@ -19,21 +19,33 @@ extra-source-files: CHANGELOG.md executable matebeamter main-is: Main.hs other-modules: API + , Client + , AuthUtil , Types , Types.Page + , Types.Reader + , Control + , Control.Auth + , Control.User , View , View.Auth + , View.User -- other-extensions: build-depends: base ^>=4.12.0.0 , mateamt , servant , servant-server , servant-client + , servant-client-core , servant-blaze , servant-rawm + , aeson , blaze-html , text , warp + , wai , wai-logger + , http-client + , mtl hs-source-dirs: src default-language: Haskell2010 diff --git a/src/API.hs b/src/API.hs index cd0349d..c99d467 100644 --- a/src/API.hs +++ b/src/API.hs @@ -21,3 +21,5 @@ import View type UserAPI = "auth" :> Get '[HTML] AuthPage + + :<|> "user" :> Capture "id" Int :> Get '[HTML] UserPage diff --git a/src/AuthUtil.hs b/src/AuthUtil.hs new file mode 100644 index 0000000..e7f5b6e --- /dev/null +++ b/src/AuthUtil.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +module AuthUtil where + +import Servant hiding (addHeader) +import Servant.Client +import Servant.Client.Core.Auth +import Servant.Client.Core.Request (addHeader) + +authenticateReq s req = addHeader "Authentication" s req + +type instance AuthClientData (AuthProtect "header-auth") = String diff --git a/src/Client.hs b/src/Client.hs new file mode 100644 index 0000000..68da962 --- /dev/null +++ b/src/Client.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE PackageImports #-} +module Client where + +import Servant +import Servant.Client + +import Network.HTTP.Client hiding (Proxy) + +import Control.Monad.IO.Class (liftIO) + +-- imports from mateamt + +import qualified "mateamt" API as MT +import qualified "mateamt" Types as MT + +-- internal imports + +import Types + +mateApi :: Proxy MT.MateAPI +mateApi = Proxy + +( authGet :<|> + authSend :<|> + authLogout :<|> + + userNew :<|> + userGet :<|> + userUpdate :<|> + userList :<|> + userRecharge :<|> + userTransfer :<|> + + productNew :<|> + productOverview :<|> + productStockRefill :<|> + productStockUpdate :<|> + productList :<|> + + buy :<|> + + journalShow :<|> + + avatarGet :<|> + avatarInsert :<|> + avatarUpdate :<|> + avatarList + ) = client mateApi + +getClients clientEnv = hoistClient + mateApi + ( fmap (either (error . show) id) + . (`runClientM` mkClientEnv clientEnv (BaseUrl Http "localhost" 8000 "/"))) + (client mateApi) diff --git a/src/Control.hs b/src/Control.hs new file mode 100644 index 0000000..cc596b4 --- /dev/null +++ b/src/Control.hs @@ -0,0 +1,6 @@ +module Control + ( module C + ) where + +import Control.Auth as C +import Control.User as C diff --git a/src/Control/Auth.hs b/src/Control/Auth.hs new file mode 100644 index 0000000..3971745 --- /dev/null +++ b/src/Control/Auth.hs @@ -0,0 +1,12 @@ +module Control.Auth where + +import Servant.Server (Server) + +-- internal imports + +import Types +import View + +authControl :: UserHandler AuthPage +authControl = do + error "Not yet implemented properly" diff --git a/src/Control/User.hs b/src/Control/User.hs new file mode 100644 index 0000000..da65d8b --- /dev/null +++ b/src/Control/User.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +module Control.User where + +import Servant.Server (Server) +import Servant.Client +import Servant.Client.Core.Auth + +import Data.Aeson (decode) + +import Control.Monad.Reader (ask) +import Control.Monad.IO.Class (liftIO) + +import Network.HTTP.Client + +-- imports from mateamt + +import qualified "mateamt" Types as MT + +-- internal imports + +import Types +import Client +import View +import AuthUtil +import API + +userListControl :: Int -> UserHandler UserPage +userListControl uid = do + manager <- liftIO $ newManager defaultManagerSettings + muser <- liftIO $ runClientM + (userList (Just MT.All)) + (mkClientEnv manager (BaseUrl Http "localhost" 8000 "")) + error (show muser) diff --git a/src/Main.hs b/src/Main.hs index 911b77f..aff1a45 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -6,23 +6,35 @@ import Servant.Server import Network.Wai.Handler.Warp import Network.Wai.Logger +import Network.HTTP.Client hiding (Proxy) + +import Control.Monad.Reader + -- internal imports import API import Types import View +import Control main :: IO () main = do + manager <- newManager defaultManagerSettings withStdoutLogger $ \ilog -> do let settings = setPort 3000 $ setLogger ilog defaultSettings - runSettings settings app + initState = ReadState + { rsManager = manager + } + runSettings settings (userApp initState) -app :: Application -app = serve userApi userServer +userApp initState = serveWithContext userApi (EmptyContext) $ + hoistServerWithContext + userApi + Proxy + (`runReaderT` initState) + ( authControl + :<|> userListControl + ) userApi :: Proxy UserAPI userApi = Proxy - -userServer :: Server UserAPI -userServer = return authPage diff --git a/src/Model.hs b/src/Model.hs new file mode 100644 index 0000000..0ed3bdc --- /dev/null +++ b/src/Model.hs @@ -0,0 +1,5 @@ +module Model + ( module M + ) where + +import Model.Auth as M diff --git a/src/Model/Auth.hs b/src/Model/Auth.hs new file mode 100644 index 0000000..117f81e --- /dev/null +++ b/src/Model/Auth.hs @@ -0,0 +1,3 @@ +module Model.Auth where + + diff --git a/src/Model/User.hs b/src/Model/User.hs new file mode 100644 index 0000000..0ea70af --- /dev/null +++ b/src/Model/User.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +module Model.User where + +import qualified "mateamt" Types as MT + + diff --git a/src/Types.hs b/src/Types.hs index bff778a..57fa76a 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -3,3 +3,4 @@ module Types ) where import Types.Page as T +import Types.Reader as T diff --git a/src/Types/Reader.hs b/src/Types/Reader.hs new file mode 100644 index 0000000..618ad67 --- /dev/null +++ b/src/Types/Reader.hs @@ -0,0 +1,13 @@ +module Types.Reader where + +import Network.HTTP.Client (Manager) + +import Servant (Handler) + +import Control.Monad.Reader (ReaderT) + +data ReadState = ReadState + { rsManager :: Manager + } + +type UserHandler = ReaderT ReadState Handler diff --git a/src/View.hs b/src/View.hs index 24b6bf5..c2782ae 100644 --- a/src/View.hs +++ b/src/View.hs @@ -3,3 +3,4 @@ module View ) where import View.Auth as V +import View.User as V diff --git a/src/View/User.hs b/src/View/User.hs new file mode 100644 index 0000000..18664b9 --- /dev/null +++ b/src/View/User.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE OverloadedStrings #-} +module View.User where + +import qualified Text.Blaze.Html5 as H + +import Types + +type UserPage = H.Html + +userPage :: UserPage +userPage = template initPage $ do + H.p $ "Test"