Initial commit

This commit is contained in:
Julian Ospald 2022-04-09 21:36:23 +02:00
commit 2d3c229608
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
12 changed files with 557 additions and 0 deletions

1
.gitignore vendored Normal file
View File

@ -0,0 +1 @@
dist-newstyle/

5
CHANGELOG.md Normal file
View File

@ -0,0 +1,5 @@
# Revision history for soostone
## 0.1.0.0 -- YYYY-mm-dd
* First version. Released on an unsuspecting world.

15
README.md Normal file
View File

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

84
app/Main.hs Normal file
View File

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

8
cabal.project Normal file
View File

@ -0,0 +1,8 @@
packages: ./soostone.cabal
with-compiler: ghc-8.10.7
optional-packages: ./vendored/*/*.cabal
allow-newer: text

216
cabal.project.freeze Normal file
View File

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

2
hie.yaml Normal file
View File

@ -0,0 +1,2 @@
cradle:
cabal:

34
lib/Soostone.hs Normal file
View File

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

27
lib/Soostone/API.hs Normal file
View File

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

38
lib/Soostone/Handlers.hs Normal file
View File

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

58
lib/Soostone/Types.hs Normal file
View File

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

69
soostone.cabal Normal file
View File

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