diff --git a/.gitignore b/.gitignore index e60400359..c50ada2bf 100644 --- a/.gitignore +++ b/.gitignore @@ -1 +1,3 @@ -data.db \ No newline at end of file +*.db +*.db-shm +*.db-wal \ No newline at end of file diff --git a/shell.nix b/shell.nix index 96c18c8e9..3312fef13 100644 --- a/shell.nix +++ b/shell.nix @@ -8,6 +8,9 @@ in pkgs.mkShell { hpkgs.resource-pool hpkgs.sqlite-simple hpkgs.warp + hpkgs.persistent + hpkgs.persistent-sqlite + hpkgs.persistent-template ])) ]; } diff --git a/src/API.hs b/src/API.hs index b2c7fd57d..b46ae5b35 100644 --- a/src/API.hs +++ b/src/API.hs @@ -1,39 +1,22 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} -------------------------------------------------------------------------------- module API where -------------------------------------------------------------------------------- -import qualified Data.Pool as DP -import qualified Database.SQLite.Simple as DB +import Data.Proxy +import Data.Text +import Database.Persist +import Servant.API -import Data.Aeson -import GHC.Generics -import GHC.TypeLits -import Network.Wai.Handler.Warp -import Servant -import Control.Monad.IO.Class +import qualified Types as T -------------------------------------------------------------------------------- -handlers :: DP.Pool DB.Connection -> Server API -handlers pool = do - getHandler pool :<|> pure 0 - -getHandler :: DP.Pool DB.Connection -> Handler Int -getHandler pool = - DP.withResource pool $ \conn -> do - result <- liftIO $ DB.query_ conn "select 2 + 2" - case result of - [DB.Only x] -> pure x - _ -> pure (-1) - -type API = "number" :> Get '[JSON] Int - :<|> "other" :> Post '[JSON] Int - -main :: IO () -main = do - pool <- DP.createPool (DB.open "data.db") DB.close 1 0.5 1 - run 3000 (serve (Proxy @ API) (handlers pool)) +type API = "user" + :> ReqBody '[JSON] T.User + :> Post '[JSON] (Maybe (Key T.User)) + :<|> "user" + :> Capture "name" Text + :> Get '[JSON] (Maybe T.User) diff --git a/src/App.hs b/src/App.hs new file mode 100644 index 000000000..1f7754517 --- /dev/null +++ b/src/App.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +-------------------------------------------------------------------------------- +module App where +-------------------------------------------------------------------------------- +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Logger (runStderrLoggingT) +import Database.Persist.Sqlite ( ConnectionPool, createSqlitePool + , runSqlPool, runSqlPersistMPool + , runMigration, selectFirst, (==.) + , insert, entityVal) +import Data.String.Conversions (cs) +import Data.Text (Text) +import Network.Wai.Handler.Warp as Warp +import Servant + +import API +import Types +-------------------------------------------------------------------------------- + +server :: ConnectionPool -> Server API +server pool = + userAddH :<|> userGetH + where + userAddH newUser = liftIO $ userAdd newUser + userGetH name = liftIO $ userGet name + + userAdd :: User -> IO (Maybe (Key User)) + userAdd newUser = flip runSqlPersistMPool pool $ do + exists <- selectFirst [UserName ==. (userName newUser)] [] + case exists of + Nothing -> Just <$> insert newUser + Just _ -> return Nothing + + userGet :: Text -> IO (Maybe User) + userGet name = flip runSqlPersistMPool pool $ do + mUser <- selectFirst [UserName ==. name] [] + return $ entityVal <$> mUser + +app :: ConnectionPool -> Application +app pool = serve (Proxy @ API) $ server pool + +mkApp :: FilePath -> IO Application +mkApp sqliteFile = do + pool <- runStderrLoggingT $ do + createSqlitePool (cs sqliteFile) 5 + + runSqlPool (runMigration migrateAll) pool + return $ app pool + +run :: FilePath -> IO () +run sqliteFile = + Warp.run 3000 =<< mkApp sqliteFile diff --git a/src/Main.hs b/src/Main.hs index 7ec8d9f8c..ea2ad2621 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,5 +1,7 @@ module Main where +-------------------------------------------------------------------------------- +import qualified App +-------------------------------------------------------------------------------- main :: IO () -main = do - putStrLn "Working..." +main = App.run "sqlite.db" diff --git a/src/Types.hs b/src/Types.hs new file mode 100644 index 000000000..3a410dc4b --- /dev/null +++ b/src/Types.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +-------------------------------------------------------------------------------- +module Types where +-------------------------------------------------------------------------------- +import Data.Aeson +import Data.Text +import Database.Persist.TH +-------------------------------------------------------------------------------- + +share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| +User + name Text + age Int + UniqueName name + deriving Eq Read Show +|] + +instance FromJSON User where + parseJSON = withObject "User" $ \ v -> + User <$> v .: "name" + <*> v .: "age" + +instance ToJSON User where + toJSON (User name age) = + object [ "name" .= name + , "age" .= age + ]