Add OrvilleM monad and RawSql modules
This commit is contained in:
@@ -15,19 +15,13 @@ build-type: Simple
|
|||||||
|
|
||||||
library
|
library
|
||||||
exposed-modules:
|
exposed-modules:
|
||||||
Orville.SQLite
|
|
||||||
Orville.SQLite.AutoMigration
|
|
||||||
Orville.SQLite.Execution
|
|
||||||
Orville.SQLite.FieldDefinition
|
|
||||||
Orville.SQLite.Monad
|
Orville.SQLite.Monad
|
||||||
Orville.SQLite.RawSql
|
Orville.SQLite.RawSql
|
||||||
Orville.SQLite.SqlMarshaller
|
|
||||||
Orville.SQLite.SqlType
|
|
||||||
Orville.SQLite.TableDefinition
|
|
||||||
hs-source-dirs: src
|
hs-source-dirs: src
|
||||||
build-depends:
|
build-depends:
|
||||||
base >=4.17 && <5
|
base >=4.17 && <5
|
||||||
, direct-sqlite
|
, direct-sqlite
|
||||||
|
, mtl
|
||||||
, text
|
, text
|
||||||
, bytestring
|
, bytestring
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
|
|||||||
@@ -0,0 +1,41 @@
|
|||||||
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
|
module Orville.SQLite.Monad
|
||||||
|
( OrvilleM
|
||||||
|
, withConnection
|
||||||
|
, openConnection
|
||||||
|
, closeConnection
|
||||||
|
, runOrvilleM
|
||||||
|
, withTransaction
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Control.Monad.IO.Class (MonadIO (liftIO))
|
||||||
|
import Control.Monad.Reader (ReaderT, runReaderT, ask, MonadReader)
|
||||||
|
import qualified Data.Text as T
|
||||||
|
import qualified Database.SQLite3 as SQLite3
|
||||||
|
|
||||||
|
newtype OrvilleM a = OrvilleM
|
||||||
|
{ unOrvilleM :: ReaderT SQLite3.Database IO a
|
||||||
|
}
|
||||||
|
deriving (Functor, Applicative, Monad, MonadIO, MonadReader SQLite3.Database)
|
||||||
|
|
||||||
|
runOrvilleM :: SQLite3.Database -> OrvilleM a -> IO a
|
||||||
|
runOrvilleM db action = runReaderT (unOrvilleM action) db
|
||||||
|
|
||||||
|
withConnection :: SQLite3.Database -> OrvilleM a -> IO a
|
||||||
|
withConnection = runOrvilleM
|
||||||
|
|
||||||
|
openConnection :: String -> IO SQLite3.Database
|
||||||
|
openConnection path = SQLite3.open (T.pack path)
|
||||||
|
|
||||||
|
closeConnection :: SQLite3.Database -> IO ()
|
||||||
|
closeConnection = SQLite3.close
|
||||||
|
|
||||||
|
withTransaction :: OrvilleM a -> OrvilleM a
|
||||||
|
withTransaction action = do
|
||||||
|
db <- ask
|
||||||
|
liftIO $ SQLite3.exec db "BEGIN TRANSACTION"
|
||||||
|
result <- action
|
||||||
|
liftIO $ SQLite3.exec db "COMMIT"
|
||||||
|
pure result
|
||||||
@@ -0,0 +1,50 @@
|
|||||||
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||||
|
|
||||||
|
module Orville.SQLite.RawSql
|
||||||
|
( RawSql (..)
|
||||||
|
, fromString
|
||||||
|
, toRawSql
|
||||||
|
, intercalate
|
||||||
|
, fromText
|
||||||
|
, space
|
||||||
|
, comma
|
||||||
|
, leftParen
|
||||||
|
, rightParen
|
||||||
|
, equals
|
||||||
|
) where
|
||||||
|
|
||||||
|
import qualified Data.Text as T
|
||||||
|
|
||||||
|
newtype RawSql = RawSql {unRawSql :: String}
|
||||||
|
deriving (Show, Eq, Semigroup, Monoid)
|
||||||
|
|
||||||
|
fromString :: String -> RawSql
|
||||||
|
fromString = RawSql
|
||||||
|
|
||||||
|
toRawSql :: RawSql -> RawSql
|
||||||
|
toRawSql = id
|
||||||
|
|
||||||
|
fromText :: T.Text -> RawSql
|
||||||
|
fromText = RawSql . T.unpack
|
||||||
|
|
||||||
|
intercalate :: RawSql -> [RawSql] -> RawSql
|
||||||
|
intercalate sep parts = RawSql . intercalateStr (unRawSql sep) $ map unRawSql parts
|
||||||
|
where
|
||||||
|
intercalateStr _ [] = ""
|
||||||
|
intercalateStr _ [x] = x
|
||||||
|
intercalateStr s (x : xs) = x <> s <> intercalateStr s xs
|
||||||
|
|
||||||
|
space :: RawSql
|
||||||
|
space = RawSql " "
|
||||||
|
|
||||||
|
comma :: RawSql
|
||||||
|
comma = RawSql ", "
|
||||||
|
|
||||||
|
leftParen :: RawSql
|
||||||
|
leftParen = RawSql "("
|
||||||
|
|
||||||
|
rightParen :: RawSql
|
||||||
|
rightParen = RawSql ")"
|
||||||
|
|
||||||
|
equals :: RawSql
|
||||||
|
equals = RawSql " = "
|
||||||
Reference in New Issue
Block a user