From 2d3c229608c6c6cc6be21b93f6ef4d4232b9dc4d Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Sat, 9 Apr 2022 21:36:23 +0200 Subject: [PATCH] Initial commit --- .gitignore | 1 + CHANGELOG.md | 5 + README.md | 15 +++ app/Main.hs | 84 +++++++++++++++ cabal.project | 8 ++ cabal.project.freeze | 216 +++++++++++++++++++++++++++++++++++++++ hie.yaml | 2 + lib/Soostone.hs | 34 ++++++ lib/Soostone/API.hs | 27 +++++ lib/Soostone/Handlers.hs | 38 +++++++ lib/Soostone/Types.hs | 58 +++++++++++ soostone.cabal | 69 +++++++++++++ 12 files changed, 557 insertions(+) create mode 100644 .gitignore create mode 100644 CHANGELOG.md create mode 100644 README.md create mode 100644 app/Main.hs create mode 100644 cabal.project create mode 100644 cabal.project.freeze create mode 100644 hie.yaml create mode 100644 lib/Soostone.hs create mode 100644 lib/Soostone/API.hs create mode 100644 lib/Soostone/Handlers.hs create mode 100644 lib/Soostone/Types.hs create mode 100644 soostone.cabal diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..c33954f --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +dist-newstyle/ diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 index 0000000..ecdf49f --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for soostone + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/README.md b/README.md new file mode 100644 index 0000000..7380b11 --- /dev/null +++ b/README.md @@ -0,0 +1,15 @@ +# Soostone + +## Request examples + +### Insert + +```sh +curl -v -H 'Content-Type: application/json' -X POST --data '"abc"' http://localhost:9000/api/v1/input +``` + +### Query + +```sh +curl -v -X GET 'http://localhost:9000/api/v1/query?key=abc' +``` diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 index 0000000..3d42603 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Main where + +import Soostone + +import Control.Monad +import Data.Version (showVersion) +import Database.SQLite.Simple +import Network.Wai.Handler.Warp ( run ) +import Options.Applicative +import Paths_soostone ( version ) +import Prometheus +import Prometheus.Metric.GHC +import Prometheus.Metric.Proc +import Text.Read ( readEither ) + + +versioner :: Parser (a -> a) +versioner = infoOption (showVersion version) (long "version" <> help "Show version" <> hidden) + +data Command = Run ServerConfig + +data Config = Config { + serverCommand :: Command + } + +parseConfig :: Parser Config +parseConfig = Config <$> parseCommands + +data ServerConfig = ServerConfig { + serverPort :: Int + , sqliteDB :: FilePath + } + +parseServerConf :: Parser ServerConfig +parseServerConf = ServerConfig + <$> option + (eitherReader (readEither @Int)) + (long "server-port" <> metavar "SERVER_PORT" <> help + "Port to use for the REST server" + <> showDefault + <> value 9000 + ) + <*> strOption + ( long "sqlite-db" + <> metavar "SQLITE_DB" + <> help "SQLite relation/database" + <> showDefault + <> value "soostone.sqlite3" + ) + +parseCommands :: Parser Command +parseCommands = subparser $ + command + "run" + (info + (Run <$> parseServerConf <**> helper) + ( progDesc "Run the REST API webserver" + ) + ) + + +main :: IO () +main = do + Config{ .. } <- + execParser (info (parseConfig <**> helper <**> versioner) (fullDesc <> progDesc "Soostone")) + + case serverCommand of + Run ServerConfig{..} -> do + when (sqliteDB == ":memory:") $ fail "In-memory DB is not supported!" + con <- open sqliteDB + createTables con + let appState = AppState { sqliteFile = sqliteDB } + void $ register ghcMetrics + void $ register procMetrics + run serverPort (middleWare $ app appState) + where + createTables :: Connection -> IO () + createTables con = do + execute_ con "CREATE TABLE IF NOT EXISTS keys (id INTEGER PRIMARY KEY, key TEXT, count INTEGER)" + + diff --git a/cabal.project b/cabal.project new file mode 100644 index 0000000..50fd5ad --- /dev/null +++ b/cabal.project @@ -0,0 +1,8 @@ +packages: ./soostone.cabal + +with-compiler: ghc-8.10.7 + +optional-packages: ./vendored/*/*.cabal + +allow-newer: text + diff --git a/cabal.project.freeze b/cabal.project.freeze new file mode 100644 index 0000000..d6bf3fb --- /dev/null +++ b/cabal.project.freeze @@ -0,0 +1,216 @@ +active-repositories: hackage.haskell.org:merge +constraints: any.Cabal ==3.6.3.0, + Cabal -bundled-binary-generic, + any.HUnit ==1.6.2.0, + any.OneTuple ==0.3.1, + any.Only ==0.1, + any.QuickCheck ==2.14.2, + QuickCheck -old-random +templatehaskell, + any.StateVar ==1.2.2, + any.aeson ==2.0.3.0, + aeson -cffi +ordered-keymap, + any.ansi-terminal ==0.11.1, + ansi-terminal -example, + any.ansi-wl-pprint ==0.6.9, + ansi-wl-pprint -example, + any.appar ==0.1.8, + any.array ==0.5.4.0, + any.asn1-encoding ==0.9.6, + any.asn1-parse ==0.9.5, + any.asn1-types ==0.3.4, + any.assoc ==1.0.2, + any.async ==2.2.4, + async -bench, + any.atomic-primops ==0.8.4, + atomic-primops -debug, + any.attoparsec ==0.14.4, + attoparsec -developer, + any.attoparsec-iso8601 ==1.0.2.1, + attoparsec-iso8601 -developer -fast, + any.auto-update ==0.1.6, + any.base ==4.14.3.0, + any.base-compat ==0.12.1, + any.base-compat-batteries ==0.12.1, + any.base-orphans ==0.8.6, + any.base64-bytestring ==1.2.1.0, + any.basement ==0.0.14, + any.bifunctors ==5.5.11, + bifunctors +semigroups +tagged, + any.binary ==0.8.9.0, + any.blaze-builder ==0.4.2.2, + any.blaze-html ==0.9.1.2, + any.blaze-markup ==0.8.2.8, + any.blaze-textual ==0.2.2.1, + blaze-textual -developer -integer-simple +native, + any.boring ==0.2, + boring +tagged, + any.bsb-http-chunked ==0.0.0.4, + any.byteorder ==1.0.4, + any.bytestring ==0.11.3.0, + any.cabal-doctest ==1.0.9, + any.call-stack ==0.4.0, + any.case-insensitive ==1.2.1.0, + any.clock ==0.8.3, + clock -llvm, + any.colour ==2.3.6, + any.comonad ==5.0.8, + comonad +containers +distributive +indexed-traversable, + any.constraints ==0.13.3, + any.containers ==0.6.5.1, + any.contravariant ==1.5.5, + contravariant +semigroups +statevar +tagged, + any.cookie ==0.4.5, + any.cryptonite ==0.30, + cryptonite -check_alignment +integer-gmp -old_toolchain_inliner +support_aesni +support_deepseq -support_pclmuldq +support_rdrand -support_sse +use_target_attributes, + any.data-default ==0.7.1.1, + any.data-default-class ==0.1.2.0, + any.data-default-instances-containers ==0.0.1, + any.data-default-instances-dlist ==0.0.1, + any.data-default-instances-old-locale ==0.0.1, + any.data-fix ==0.3.2, + any.data-sketches ==0.3.1.0, + any.data-sketches-core ==0.1.0.0, + any.dec ==0.0.4, + any.deepseq ==1.4.4.0, + any.direct-sqlite ==2.3.26, + direct-sqlite +fulltextsearch +haveusleep +json1 -systemlib +urifilenames, + any.directory ==1.3.7.0, + any.distributive ==0.6.2.1, + distributive +semigroups +tagged, + any.dlist ==1.0, + dlist -werror, + any.easy-file ==0.2.2, + any.exceptions ==0.10.4, + any.fast-logger ==3.1.1, + any.file-embed ==0.0.15.0, + any.filepath ==1.4.2.1, + any.filtrable ==0.1.6.0, + filtrable +containers, + any.ghc-boot-th ==8.10.7, + any.ghc-prim ==0.6.1, + any.hashable ==1.4.0.2, + hashable +containers +integer-gmp -random-initial-seed, + any.hourglass ==0.2.12, + any.hsc2hs ==0.68.8, + hsc2hs -in-ghc-tree, + any.http-api-data ==0.4.3, + http-api-data -use-text-show, + any.http-date ==0.0.11, + any.http-media ==0.8.0.0, + any.http-types ==0.12.3, + any.http2 ==3.0.3, + http2 -devel -doc -h2spec, + any.indexed-traversable ==0.1.2, + any.indexed-traversable-instances ==0.1.1, + any.integer-gmp ==1.0.3.0, + any.integer-logarithms ==1.0.3.1, + integer-logarithms -check-bounds +integer-gmp, + any.iproute ==1.7.12, + any.math-functions ==0.3.4.2, + math-functions +system-erf +system-expm1, + any.memory ==0.17.0, + memory +support_bytestring +support_deepseq, + any.mime-types ==0.1.0.9, + any.mmorph ==1.2.0, + any.monad-control ==1.0.3.1, + any.mtl ==2.2.2, + any.mwc-random ==0.15.0.2, + any.network ==3.1.2.7, + network -devel, + any.network-byte-order ==0.1.6, + any.network-uri ==2.6.4.1, + any.old-locale ==1.0.0.7, + any.old-time ==1.1.0.3, + any.optparse-applicative ==0.16.1.0, + optparse-applicative +process, + any.parsec ==3.1.15.0, + any.pem ==0.2.4, + any.pretty ==1.1.3.6, + any.primitive ==0.7.3.0, + any.process ==1.6.14.0, + any.prometheus-client ==1.1.0, + any.prometheus-metrics-ghc ==1.0.1.2, + any.prometheus-proc ==0.1.4.0, + any.psqueues ==0.2.7.3, + any.random ==1.2.1, + any.regex-applicative ==0.3.4, + any.resourcet ==1.2.4.3, + any.rts ==1.0.1, + any.scientific ==0.3.7.0, + scientific -bytestring-builder -integer-simple, + any.semialign ==1.2.0.1, + semialign +semigroupoids, + any.semigroupoids ==5.3.7, + semigroupoids +comonad +containers +contravariant +distributive +tagged +unordered-containers, + any.semigroups ==0.19.2, + semigroups +binary +bytestring -bytestring-builder +containers +deepseq +hashable +tagged +template-haskell +text +transformers +unordered-containers, + any.servant ==0.19, + any.servant-server ==0.19.1, + any.simple-sendfile ==0.2.30, + simple-sendfile +allow-bsd, + any.singleton-bool ==0.1.6, + any.some ==1.0.3, + some +newtype-unsafe, + any.sop-core ==0.5.0.2, + any.splitmix ==0.1.0.4, + splitmix -optimised-mixer, + any.sqlite-simple ==0.4.18.0, + any.stm ==2.5.0.1, + any.streaming-commons ==0.2.2.4, + streaming-commons -use-bytestring-builder, + any.strict ==0.4.0.1, + strict +assoc, + any.string-conversions ==0.4.0.1, + any.tagged ==0.8.6.1, + tagged +deepseq +transformers, + any.template-haskell ==2.16.0.0, + any.text ==2.0, + text -developer +simdutf, + any.text-short ==0.1.5, + text-short -asserts, + any.th-abstraction ==0.4.3.0, + any.th-compat ==0.1.3, + any.these ==1.1.1.1, + these +assoc, + any.time ==1.9.3, + any.time-compat ==1.9.6.1, + time-compat -old-locale, + any.time-manager ==0.0.0, + any.transformers ==0.5.6.2, + any.transformers-base ==0.4.6, + transformers-base +orphaninstances, + any.transformers-compat ==0.7.1, + transformers-compat -five +five-three -four +generic-deriving +mtl -three -two, + any.type-equality ==1, + any.unix ==2.7.2.2, + any.unix-compat ==0.5.4, + unix-compat -old-time, + any.unix-memory ==0.1.2, + any.unix-time ==0.4.7, + any.unliftio ==0.2.21.0, + any.unliftio-core ==0.2.0.1, + any.unordered-containers ==0.2.18.0, + unordered-containers -debug, + any.utf8-string ==1.0.2, + any.uuid-types ==1.0.5, + any.vault ==0.3.1.5, + vault +useghc, + any.vector ==0.12.3.1, + vector +boundschecks -internalchecks -unsafechecks -wall, + any.vector-algorithms ==0.8.0.4, + vector-algorithms +bench +boundschecks -internalchecks -llvm +properties -unsafechecks, + any.wai ==3.2.3, + any.wai-app-static ==3.1.7.4, + wai-app-static +cryptonite -print, + any.wai-extra ==3.1.8, + wai-extra -build-example, + any.wai-logger ==2.4.0, + any.wai-middleware-prometheus ==1.0.0.1, + any.warp ==3.3.20, + warp +allow-sendfilefd -network-bytestring -warp-debug +x509, + any.witherable ==0.4.2, + any.word8 ==0.1.3, + any.x509 ==1.7.6, + any.zlib ==0.6.2.3, + zlib -bundled-c-zlib -non-blocking-ffi -pkg-config +index-state: hackage.haskell.org 2022-04-09T11:10:06Z diff --git a/hie.yaml b/hie.yaml new file mode 100644 index 0000000..04cd243 --- /dev/null +++ b/hie.yaml @@ -0,0 +1,2 @@ +cradle: + cabal: diff --git a/lib/Soostone.hs b/lib/Soostone.hs new file mode 100644 index 0000000..78f75e5 --- /dev/null +++ b/lib/Soostone.hs @@ -0,0 +1,34 @@ +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 +import Servant + + +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 diff --git a/lib/Soostone/API.hs b/lib/Soostone/API.hs new file mode 100644 index 0000000..8d1973f --- /dev/null +++ b/lib/Soostone/API.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DeriveGeneric #-} + +module Soostone.API where + +import Soostone.Types + +import Servant +import Servant.API.Generic + + +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 + diff --git a/lib/Soostone/Handlers.hs b/lib/Soostone/Handlers.hs new file mode 100644 index 0000000..d0215cd --- /dev/null +++ b/lib/Soostone/Handlers.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Soostone.Handlers where + +import Soostone.Types + +import Data.Functor +import Database.SQLite.Simple +import Control.Monad.Catch +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) diff --git a/lib/Soostone/Types.hs b/lib/Soostone/Types.hs new file mode 100644 index 0000000..5ea1269 --- /dev/null +++ b/lib/Soostone/Types.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Soostone.Types where + +import Control.Monad.Catch ( MonadMask, MonadCatch, MonadThrow ) +import Control.Monad.Error.Class +import Control.Monad.IO.Class ( MonadIO(..) ) +import Control.Monad.Reader.Class ( MonadReader ) +import Control.Monad.Trans.Reader (ReaderT) +import Data.Aeson hiding (Key) +import Data.String +import Data.Text ( Text ) +import Database.SQLite.Simple +import Database.SQLite.Simple.ToField +import Servant +import Servant.API.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 } diff --git a/soostone.cabal b/soostone.cabal new file mode 100644 index 0000000..a03989d --- /dev/null +++ b/soostone.cabal @@ -0,0 +1,69 @@ +cabal-version: 2.4 +name: soostone +version: 0.1.0.0 +synopsis: A stringy backend +description: A really stringy backend +bug-reports: https://gogs.hasufell.de/hasufell/soostone/issues +license: BSD-3-Clause +author: Julian Ospald +maintainer: hasufell@posteo.de +copyright: 2022 Julian Ospald +category: Backend +extra-source-files: CHANGELOG.md + +source-repository head + type: git + location: https://gogs.hasufell.de/hasufell/soostone.git + +common deps + build-depends: + , aeson ^>=2.0 + , base >=4.13 && <5.0 + , bytestring ^>=0.11 + , exceptions ^>=0.10 + , mtl ^>=2.2 + , optparse-applicative ^>=0.16 + , prometheus-client ^>=1.1 + , prometheus-metrics-ghc ^>=1.0 + , prometheus-proc ^>=0.1 + , servant ^>=0.19 + , servant-server ^>=0.19 + , sqlite-simple ^>=0.4 + , text ^>=2.0 + , transformers ^>=0.5 + , wai ^>=3.2.3 + , wai-middleware-prometheus ^>=1.0 + , warp ^>=3.3.19 + + default-extensions: + BangPatterns + ImportQualifiedPost + LambdaCase + MultiWayIf + PackageImports + RecordWildCards + ScopedTypeVariables + StrictData + TupleSections + + default-language: Haskell2010 + ghc-options: + -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns + -fwarn-incomplete-record-updates + +executable soostone + import: deps + main-is: Main.hs + other-modules: Paths_soostone + autogen-modules: Paths_soostone + hs-source-dirs: app + build-depends: soostone + +library + import: deps + hs-source-dirs: lib + exposed-modules: + Soostone + Soostone.API + Soostone.Handlers + Soostone.Types