Initial commit
This commit is contained in:
commit
6fa9746f36
GPG Key ID:
3786C5262ECB4A3F
1
.gitignore
vendored
Normal file
1
.gitignore
vendored
Normal file
@ -0,0 +1 @@
|
|||||||
|
dist-newstyle/
|
||||||
5
CHANGELOG.md
Normal file
5
CHANGELOG.md
Normal file
@ -0,0 +1,5 @@
|
|||||||
|
# Revision history for soostone
|
||||||
|
|
||||||
|
## 0.1.0.0 -- YYYY-mm-dd
|
||||||
|
|
||||||
|
* First version. Released on an unsuspecting world.
|
||||||
29
README.md
Normal file
29
README.md
Normal file
@ -0,0 +1,29 @@
|
|||||||
|
# Soostone
|
||||||
|
|
||||||
|
## Start
|
||||||
|
|
||||||
|
First create tables:
|
||||||
|
|
||||||
|
```sh
|
||||||
|
soostone create-tables
|
||||||
|
```
|
||||||
|
|
||||||
|
Then start backend:
|
||||||
|
|
||||||
|
```sh
|
||||||
|
soostone run
|
||||||
|
```
|
||||||
|
|
||||||
|
## 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'
|
||||||
|
```
|
||||||
112
app/Main.hs
Normal file
112
app/Main.hs
Normal file
@ -0,0 +1,112 @@
|
|||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
|
||||||
|
module Main where
|
||||||
|
|
||||||
|
import Soostone ( app, middleWare, AppState(AppState, sqliteFile) )
|
||||||
|
|
||||||
|
import Control.Monad ( void, when )
|
||||||
|
import Data.Version (showVersion)
|
||||||
|
import Database.SQLite.Simple ( execute_, open, Connection )
|
||||||
|
import Network.Wai.Handler.Warp ( run )
|
||||||
|
import Options.Applicative
|
||||||
|
( fullDesc,
|
||||||
|
execParser,
|
||||||
|
progDesc,
|
||||||
|
helper,
|
||||||
|
(<**>),
|
||||||
|
info,
|
||||||
|
command,
|
||||||
|
subparser,
|
||||||
|
strOption,
|
||||||
|
value,
|
||||||
|
showDefault,
|
||||||
|
metavar,
|
||||||
|
eitherReader,
|
||||||
|
option,
|
||||||
|
hidden,
|
||||||
|
help,
|
||||||
|
long,
|
||||||
|
infoOption,
|
||||||
|
Parser )
|
||||||
|
import Paths_soostone ( version )
|
||||||
|
import Prometheus ( register )
|
||||||
|
import Prometheus.Metric.GHC ( ghcMetrics )
|
||||||
|
import Prometheus.Metric.Proc ( procMetrics )
|
||||||
|
import Text.Read ( readEither )
|
||||||
|
|
||||||
|
|
||||||
|
versioner :: Parser (a -> a)
|
||||||
|
versioner = infoOption (showVersion version) (long "version" <> help "Show version" <> hidden)
|
||||||
|
|
||||||
|
data Command = Run ServerConfig
|
||||||
|
| Create 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"
|
||||||
|
)
|
||||||
|
)
|
||||||
|
<>
|
||||||
|
command
|
||||||
|
"create-tables"
|
||||||
|
(info
|
||||||
|
(Create <$> parseServerConf <**> helper)
|
||||||
|
( progDesc "Create the database"
|
||||||
|
)
|
||||||
|
)
|
||||||
|
|
||||||
|
|
||||||
|
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!"
|
||||||
|
let appState = AppState { sqliteFile = sqliteDB }
|
||||||
|
void $ register ghcMetrics
|
||||||
|
void $ register procMetrics
|
||||||
|
run serverPort (middleWare $ app appState)
|
||||||
|
Create ServerConfig{..} -> do
|
||||||
|
when (sqliteDB == ":memory:") $ fail "In-memory DB is not supported!"
|
||||||
|
con <- open sqliteDB
|
||||||
|
createTables con
|
||||||
|
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
8
cabal.project
Normal 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
216
cabal.project.freeze
Normal 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
|
||||||
35
lib/Soostone.hs
Normal file
35
lib/Soostone.hs
Normal file
@ -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
|
||||||
36
lib/Soostone/API.hs
Normal file
36
lib/Soostone/API.hs
Normal file
@ -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
|
||||||
46
lib/Soostone/Handlers.hs
Normal file
46
lib/Soostone/Handlers.hs
Normal file
@ -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)
|
||||||
60
lib/Soostone/Types.hs
Normal file
60
lib/Soostone/Types.hs
Normal file
@ -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 }
|
||||||
69
soostone.cabal
Normal file
69
soostone.cabal
Normal 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
|
||||||
Loading…
Reference in New Issue
Block a user