add initial server

5 files changed, 267 insertions, 0 deletions

diff --git a/src/Shop/API.hs b/src/Shop/API.hs
new file mode 100644
index 0000000..d934a0d
--- /dev/null
+++ b/src/Shop/API.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE DataKinds     #-}
+{-# LANGUAGE PolyKinds     #-}
+{-# LANGUAGE TypeOperators #-}
+module Shop.API where
+
+import           Protolude
+import           Data.Proxy  (Proxy (..))
+import           Servant.API
+import           Shop.Types
+
+
+type ShopAPI =
+         "charge" :> ReqBody '[JSON] ChargeForm :> Post '[JSON] ChargeResponse
+
+shopAPI :: Proxy ShopAPI
+shopAPI = Proxy
diff --git a/src/Shop/Config.hs b/src/Shop/Config.hs
new file mode 100644
index 0000000..7c79e28
--- /dev/null
+++ b/src/Shop/Config.hs
@@ -0,0 +1,90 @@
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings     #-}
+module Shop.Config where
+
+import           Protolude
+import           Control.Monad.Logger                 (MonadLogger,
+                                                       runNoLoggingT,
+                                                       runStdoutLoggingT)
+import           Control.Monad.Trans.Control          (MonadBaseControl)
+import           Network.Wai                          (Middleware)
+import           Network.Wai.Middleware.RequestLogger (logStdout, logStdoutDev)
+import           Network.Wai.Handler.Warp             (HostPreference)
+import           System.Environment                   (lookupEnv, setEnv)
+import           Path
+import           Data.ByteString.Char8                (pack)
+import           GHC.Show                             (Show(..))
+
+
+data Environment =
+      Development
+    | Test
+    | Production
+    deriving (Eq, Show, Read)
+
+setLogger :: Environment -> Middleware
+setLogger Test = identity
+setLogger Development = logStdoutDev
+setLogger Production = logStdout
+
+data Config = Config
+    { getConfigEnv     :: !Environment
+    , getConfigHost    :: !HostPreference
+    , getConfigPort    :: !Int
+    , getConfigSocket  :: !(Maybe FilePath)
+    , getConfigUrlPath :: !Text
+    }
+
+data ConfigMonoid = ConfigMonoid
+    { configMonoidEnv       :: !(Maybe Environment)
+    , configMonoidHost      :: !(Maybe HostPreference)
+    , configMonoidPort      :: !(Maybe Int)
+    , configMonoidSocket    :: !(Maybe FilePath)
+    , configMonoidUrlPath   :: !(Maybe Text)
+    } deriving Show
+
+instance Monoid ConfigMonoid where
+    mempty = ConfigMonoid
+        { configMonoidEnv       = Nothing
+        , configMonoidHost      = Nothing
+        , configMonoidPort      = Nothing
+        , configMonoidSocket    = Nothing
+        , configMonoidUrlPath   = Nothing
+        }
+    mappend l r = ConfigMonoid
+        { configMonoidEnv       = configMonoidEnv l <|> configMonoidEnv r
+        , configMonoidHost      = configMonoidHost l <|> configMonoidHost r
+        , configMonoidPort      = configMonoidPort l <|> configMonoidPort r
+        , configMonoidSocket    = configMonoidSocket l <|> configMonoidSocket r
+        , configMonoidUrlPath   = configMonoidUrlPath l <|> configMonoidUrlPath r
+        }
+
+configMonoidToConfig :: ConfigMonoid -> Config
+configMonoidToConfig c = Config
+        { getConfigEnv     = fromMaybe Production (configMonoidEnv c)
+        , getConfigHost    = fromMaybe "127.0.0.1" (configMonoidHost c)
+        , getConfigPort    = fromMaybe 8080 (configMonoidPort c)
+        , getConfigSocket  = configMonoidSocket c
+        , getConfigUrlPath = fromMaybe "" (configMonoidUrlPath c)
+        }
+
+getEnvConfig :: IO ConfigMonoid
+getEnvConfig = do
+    env <- lookupEnv "SHOP_ENV"
+    host <- lookupEnv "SHOP_HOST"
+    port <- lookupEnv "SHOP_PORT"
+    socket <- lookupEnv "SHOP_SOCKET"
+    urlpath <- lookupEnv "SHOP_URLPATH"
+    return $ mempty
+        { configMonoidEnv = readMaybe =<< env
+        , configMonoidHost = readMaybe =<< host
+        , configMonoidPort = readMaybe =<< port
+        , configMonoidSocket = socket
+        , configMonoidUrlPath = readMaybe =<< urlpath
+        }
+
+getConfig :: IO Config
+getConfig = do
+    envconfig <- getEnvConfig
+    return $ configMonoidToConfig envconfig
diff --git a/src/Shop/Handler.hs b/src/Shop/Handler.hs
new file mode 100644
index 0000000..c3b0eda
--- /dev/null
+++ b/src/Shop/Handler.hs
@@ -0,0 +1,56 @@
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE TemplateHaskell       #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE TypeOperators         #-}
+
+module Shop.Handler where
+
+import           Control.Monad.Logger    (LoggingT, runStdoutLoggingT,
+                                          logInfo, logWarn)
+import           Formatting              (format, (%), fixed)
+--import           Formatting.Formatters   (fixed)
+import           Shop.Config
+import           Shop.Types
+import           Protolude               hiding (product, (%))
+import           Servant                 (throwError)
+import           Servant.Server          (ServantErr(..), err500, (:~>)(..))
+import qualified Servant.Server.Internal.Handler as SH
+
+
+type Handler = LoggingT SH.Handler
+
+type App = ReaderT Config Handler
+
+runHandler :: Handler a -> (a -> Handler a) -> (ServantErr -> Handler a) -> Handler a
+runHandler ha fa ferr = do
+    ha' <- liftIO $ runHandlerIO ha
+    case ha' of
+        Right a -> fa a
+        Left err -> ferr err
+
+appToInternalHandler :: Config -> App :~> SH.Handler
+appToInternalHandler cfg = NT appHandlerToHandler'
+  where
+    appHandlerToHandler' :: App a -> SH.Handler a
+    appHandlerToHandler' h = runStdoutLoggingT $ runReaderT h cfg
+
+runHandlerIO :: Handler a -> IO (Either ServantErr a)
+runHandlerIO = SH.runHandler . runStdoutLoggingT
+
+handlerToApp :: Handler a -> App a
+handlerToApp = lift
+
+charge :: ChargeForm -> App ChargeResponse
+charge chargeform = do
+    cfg <- ask
+    -- TODO: send email
+    let cid = "TODO"
+        a = "TODO"
+    $(logInfo) $ "Charge successfully created: \"" <> email chargeform <> "\" (" <> showPrice total <> ")"
+    return $ ChargeResponse cid a
+  where
+    total = foldl (\n a -> n + quantity a * prix (product a)) 0 (articles chargeform)
+
+showPrice :: Int -> Text
+showPrice p = toS $ format (fixed 2) (fromIntegral p / 100) <> "€"
diff --git a/src/Shop/Server.hs b/src/Shop/Server.hs
new file mode 100644
index 0000000..21d0d65
--- /dev/null
+++ b/src/Shop/Server.hs
@@ -0,0 +1,49 @@
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE TypeOperators     #-}
+module Shop.Server where
+
+import           Shop.API
+import           Shop.Config
+import           Shop.Types
+import           Shop.Handler
+import qualified Control.Category                            as Category
+import           Control.Monad.Logger                        (runStdoutLoggingT)
+import           Protolude
+import           Servant.API
+import           Servant.Server                              hiding (Handler)
+import           Network.Socket
+import           Network.Wai.Handler.Warp                    (defaultSettings,
+                                                              runSettings,
+                                                              runSettingsSocket,
+                                                              setHost,
+                                                              setPort)
+
+
+server :: ServerT ShopAPI App
+server = charge
+
+app :: Config -> Application
+app cfg = serve shopAPI (readerServer cfg)
+
+readerServer :: Config -> Server ShopAPI
+readerServer cfg = appToInternalHandler cfg `enter` server
+
+serveApp :: (Config -> Application) -> IO ()
+serveApp f = do
+    cfg <- getConfig
+    let logger = setLogger (getConfigEnv cfg)
+    let settings = setHost (getConfigHost cfg) $
+            setPort (getConfigPort cfg) defaultSettings
+    case getConfigSocket cfg of
+        Nothing -> runSettings settings (logger $ f cfg)
+        Just s -> do
+            sock <- socket AF_UNIX Stream 0
+            bind sock $ SockAddrUnix "shop-server.sock"
+            listen sock maxListenQueue
+            runSettingsSocket settings sock (logger $ f cfg)
+            close sock
+
+main :: IO ()
+main = serveApp app
diff --git a/src/Shop/Types.hs b/src/Shop/Types.hs
new file mode 100644
index 0000000..c2ddaa5
--- /dev/null
+++ b/src/Shop/Types.hs
@@ -0,0 +1,56 @@
+{-# LANGUAGE DeriveGeneric #-}
+module Shop.Types
+    ( Product(..)
+    , Article(..)
+    , ChargeForm(..)
+    , ChargeResponse(..)
+    )
+    where
+
+import           Protolude   hiding (Product(..))
+import           Data.Aeson  (ToJSON(..), FromJSON(..), Value(..))
+import           Servant.API
+
+
+data ChargeResponse = ChargeResponse
+    { chargeid     :: Text
+    , chargeamount :: Text
+    }
+    deriving (Show, Read, Generic, Eq)
+
+instance ToJSON ChargeResponse
+instance FromJSON ChargeResponse
+
+data Product = Product
+    { nom         :: Text
+    , description :: Text
+    , poids       :: Int
+    -- ^ poids en grammes
+    , prix        :: Int
+    -- ^ prix en centimes d'euros
+    }
+    deriving (Show, Read, Generic, Eq)
+
+instance ToJSON Product
+instance FromJSON Product
+
+data Article = Article
+    { product  :: Product
+    , quantity :: Int
+    }
+    deriving (Show, Read, Generic, Eq)
+
+instance ToJSON Article
+instance FromJSON Article
+
+data ChargeForm = ChargeForm
+    { name     :: Text
+    , email    :: Text
+    , phone    :: Text
+    , date     :: Text
+    , articles :: [Article]
+    }
+    deriving (Show, Read, Generic, Eq)
+
+instance ToJSON ChargeForm
+instance FromJSON ChargeForm