git vomit

This commit is contained in:
nek0 2019-09-08 12:48:57 +02:00
parent 7de4d9d0c2
commit c86ab331cc
15 changed files with 203 additions and 6 deletions

View File

@ -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

View File

@ -21,3 +21,5 @@ import View
type UserAPI =
"auth" :> Get '[HTML] AuthPage
:<|> "user" :> Capture "id" Int :> Get '[HTML] UserPage

13
src/AuthUtil.hs Normal file
View File

@ -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

64
src/Client.hs Normal file
View File

@ -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)

6
src/Control.hs Normal file
View File

@ -0,0 +1,6 @@
module Control
( module C
) where
import Control.Auth as C
import Control.User as C

12
src/Control/Auth.hs Normal file
View File

@ -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"

34
src/Control/User.hs Normal file
View File

@ -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)

View File

@ -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

5
src/Model.hs Normal file
View File

@ -0,0 +1,5 @@
module Model
( module M
) where
import Model.Auth as M

3
src/Model/Auth.hs Normal file
View File

@ -0,0 +1,3 @@
module Model.Auth where

7
src/Model/User.hs Normal file
View File

@ -0,0 +1,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
module Model.User where
import qualified "mateamt" Types as MT

View File

@ -3,3 +3,4 @@ module Types
) where
import Types.Page as T
import Types.Reader as T

13
src/Types/Reader.hs Normal file
View File

@ -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

View File

@ -3,3 +3,4 @@ module View
) where
import View.Auth as V
import View.User as V

12
src/View/User.hs Normal file
View File

@ -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"