Initial commit

lib/Soostone.hs

@@ -0,0 +1,35 @@
+module Soostone (
+    app
+  , middleWare
+  , module Soostone.API
+  , module Soostone.Types
+  , module Soostone.Handlers
+  ) where
+
+import Soostone.API
+import Soostone.Handlers
+import Soostone.Types
+
+import Control.Monad.Reader (runReaderT)
+import Network.Wai ( Middleware )
+import Network.Wai.Middleware.Prometheus ( def, prometheus )
+import Servant
+    ( Application, HasServer(ServerT), Handler, hoistServer, serve )
+
+
+soostoneServer :: ServerT SoostoneAPI AppM
+soostoneServer = API api'
+ where
+  api' = MainAPI submitKeyHandler countKeyHandler
+
+app :: AppState -> Application
+app !s = \req resp ->
+  serve api (hoistServer api nt soostoneServer) req resp
+ where
+  nt :: AppM a -> Handler a
+  nt x = flip runReaderT s $ runAppM x   
+
+
+middleWare :: Middleware
+middleWare baseApp =
+  prometheus def baseApp

lib/Soostone/API.hs

@@ -0,0 +1,36 @@
+{-# LANGUAGE DataKinds     #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE DeriveGeneric #-}
+
+module Soostone.API where
+
+import Soostone.Types ( Count, Key )
+
+import Servant
+    ( Proxy(..),
+      JSON,
+      type (:>),
+      ReqBody,
+      Post,
+      QueryParam',
+      Required,
+      Strict,
+      Get,
+      NamedRoutes )
+import Servant.API.Generic ( Generic, GenericMode(type (:-)) )
+
+
+type SoostoneAPI = NamedRoutes API
+type APIVersion = "v1"
+
+data API mode = API {
+    mainAPI   :: mode :- "api" :> APIVersion :> NamedRoutes MainAPI
+} deriving Generic
+
+data MainAPI mode = MainAPI {
+    submitKey :: mode :- "input" :> ReqBody '[JSON] Key                       :> Post '[JSON] ()
+  , countKey  :: mode :- "query" :> QueryParam' '[Required, Strict] "key" Key :> Get '[JSON] Count
+} deriving Generic
+
+api :: Proxy SoostoneAPI
+api = Proxy :: Proxy SoostoneAPI

lib/Soostone/Handlers.hs

@@ -0,0 +1,46 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications  #-}
+
+module Soostone.Handlers where
+
+import Soostone.Types
+    ( AppState(AppState, sqliteFile), AppM, Count(..), Key )
+
+import Data.Functor ( ($>) )
+import Database.SQLite.Simple
+    ( open,
+      Connection,
+      close,
+      executeNamed,
+      queryNamed,
+      withImmediateTransaction,
+      NamedParam((:=)) )
+import Control.Monad.Catch ( finally )
+import Control.Monad.Reader   ( ask )
+import Control.Monad.IO.Class ( liftIO )
+
+
+submitKeyHandler :: Key -> AppM ()
+submitKeyHandler key = withSQLiteCon $ \con -> do
+  r <- liftIO $ withImmediateTransaction con $ do
+    queryNamed @Count con "SELECT count FROM keys WHERE key=:key" [":key" := key] >>= \case
+      []  -> executeNamed con "INSERT INTO keys (key, count) VALUES (:key, :count)" [":key" := key, ":count" := Count 1] $> Right ()
+      [c] -> executeNamed con "UPDATE keys SET count = :count WHERE key = :key" [":count" := c + 1, ":key" := key] $> Right ()
+      _   -> pure $ Left "Oops"
+  case r of
+    Right _ -> pure ()
+    Left e -> fail e -- internal error
+
+
+countKeyHandler :: Key -> AppM Count
+countKeyHandler key = withSQLiteCon $ \con -> do
+  liftIO (queryNamed @Count con "SELECT count FROM keys WHERE key=:key" [":key" := key]) >>= \case
+    []  -> return (Count 0)
+    [c] -> pure c
+    _   -> fail "Oops" -- internal error
+
+withSQLiteCon :: (Connection -> AppM a) -> AppM a
+withSQLiteCon action = do
+  AppState{..} <- ask
+  conn <- liftIO $ open sqliteFile
+  action conn `finally` liftIO (close conn)

lib/Soostone/Types.hs

@@ -0,0 +1,60 @@
+{-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Soostone.Types where
+
+import Control.Monad.Catch ( MonadMask, MonadCatch, MonadThrow )
+import Control.Monad.Error.Class ( MonadError(throwError) )
+import Control.Monad.IO.Class ( MonadIO(..) )
+import Control.Monad.Reader.Class ( MonadReader )
+import Control.Monad.Trans.Reader (ReaderT)
+import Data.Aeson
+    ( defaultOptions, genericToEncoding, FromJSON, ToJSON(toEncoding) )
+import Data.String ( IsString(fromString) )
+import Data.Text ( Text )
+import Database.SQLite.Simple ( field, FromRow(..) )
+import Database.SQLite.Simple.ToField ( ToField(..) )
+import Servant
+    ( Handler, ServerError(errBody), FromHttpApiData, err500 )
+import Servant.API.Generic ( Generic )
+
+
+newtype Key = Key Text
+  deriving (FromHttpApiData, Generic)
+
+instance ToField Key where
+  toField (Key k) = toField k
+
+instance ToJSON Key where
+    toEncoding = genericToEncoding defaultOptions
+instance FromJSON Key
+
+
+newtype Count = Count Integer
+  deriving (Generic, Num)
+
+instance FromRow Count where
+  fromRow = Count <$> field
+
+instance ToField Count where
+  toField (Count c) = toField c
+
+
+instance ToJSON Count where
+    toEncoding = genericToEncoding defaultOptions
+instance FromJSON Count
+
+data AppState = AppState {
+    sqliteFile :: FilePath
+  }
+
+newtype AppM a = AppM { runAppM :: ReaderT AppState Handler a }
+  deriving
+    ( Functor, Applicative, Monad, MonadIO, Generic
+    , MonadThrow, MonadCatch, MonadMask
+    , MonadReader AppState
+    , MonadError ServerError
+    )
+
+instance MonadFail AppM where
+  fail str = throwError $ err500 { errBody = fromString str }