{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies        #-}

module Periodic.Server.Persist.SQLite
  ( SQLite
  ) where

import           Control.Monad           (void)
import           Data.Binary             (decodeOrFail)
import           Data.Byteable           (toBytes)
import           Data.ByteString         (ByteString, append)
import qualified Data.ByteString.Char8   as B (pack)
import           Data.ByteString.Lazy    (fromStrict)
import qualified Data.Foldable           as F (foldrM)
import           Data.Int                (Int64)
import           Data.Maybe              (isJust, listToMaybe)
import           Data.String             (IsString (..))
import           Database.SQLite3.Direct
import           Periodic.Server.Persist
import           Periodic.Types.Job      (FuncName (..), Job, JobName (..),
                                          getSchedAt)
import           Prelude                 hiding (foldr, lookup)
import           System.Log.Logger       (infoM)
import           UnliftIO                (Exception, Typeable, throwIO)

stateName :: State -> ByteString
stateName :: State -> ByteString
stateName Pending = "0"
stateName Running = "1"
stateName Locking = "2"

stateName' :: State -> Int64
stateName' :: State -> Int64
stateName' Pending = 0
stateName' Running = 1
stateName' Locking = 2

newtype SQLite = SQLite Database

instance Persist SQLite where
  data PersistConfig SQLite = SQLitePath Utf8
  data PersistException SQLite = SQLiteException Error deriving (PersistException SQLite -> PersistException SQLite -> Bool
(PersistException SQLite -> PersistException SQLite -> Bool)
-> (PersistException SQLite -> PersistException SQLite -> Bool)
-> Eq (PersistException SQLite)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PersistException SQLite -> PersistException SQLite -> Bool
$c/= :: PersistException SQLite -> PersistException SQLite -> Bool
== :: PersistException SQLite -> PersistException SQLite -> Bool
$c== :: PersistException SQLite -> PersistException SQLite -> Bool
Eq, Int -> PersistException SQLite -> ShowS
[PersistException SQLite] -> ShowS
PersistException SQLite -> String
(Int -> PersistException SQLite -> ShowS)
-> (PersistException SQLite -> String)
-> ([PersistException SQLite] -> ShowS)
-> Show (PersistException SQLite)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PersistException SQLite] -> ShowS
$cshowList :: [PersistException SQLite] -> ShowS
show :: PersistException SQLite -> String
$cshow :: PersistException SQLite -> String
showsPrec :: Int -> PersistException SQLite -> ShowS
$cshowsPrec :: Int -> PersistException SQLite -> ShowS
Show, Typeable)

  newPersist :: PersistConfig SQLite -> IO SQLite
newPersist (SQLitePath path) = do
    String -> String -> IO ()
infoM "Periodic.Server.Persist.SQLite" ("SQLite connected " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Utf8 -> String
forall a. Show a => a -> String
show Utf8
path)
    Either (Error, Utf8) Database
edb <- Utf8 -> IO (Either (Error, Utf8) Database)
open Utf8
path
    case Either (Error, Utf8) Database
edb of
      Left (e :: Error
e, _) -> PersistException SQLite -> IO SQLite
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PersistException SQLite -> IO SQLite)
-> PersistException SQLite -> IO SQLite
forall a b. (a -> b) -> a -> b
$ Error -> PersistException SQLite
SQLiteException Error
e
      Right db :: Database
db -> do
        Database -> IO ()
beginTx Database
db
        Database -> IO ()
createConfigTable Database
db
        Database -> IO ()
createJobTable Database
db
        Database -> IO ()
createFuncTable Database
db
        Database -> IO ()
allPending Database
db
        Database -> IO ()
commitTx Database
db
        SQLite -> IO SQLite
forall (m :: * -> *) a. Monad m => a -> m a
return (SQLite -> IO SQLite) -> SQLite -> IO SQLite
forall a b. (a -> b) -> a -> b
$ Database -> SQLite
SQLite Database
db

  member :: SQLite -> State -> FuncName -> JobName -> IO Bool
member         (SQLite db :: Database
db) = Database -> State -> FuncName -> JobName -> IO Bool
doMember Database
db
  lookup :: SQLite -> State -> FuncName -> JobName -> IO (Maybe Job)
lookup         (SQLite db :: Database
db) = Database -> State -> FuncName -> JobName -> IO (Maybe Job)
doLookup Database
db
  insert :: SQLite -> State -> FuncName -> JobName -> Job -> IO ()
insert         (SQLite db :: Database
db) = Database -> State -> FuncName -> JobName -> Job -> IO ()
doInsert Database
db
  delete :: SQLite -> FuncName -> JobName -> IO ()
delete         (SQLite db :: Database
db) = Database -> FuncName -> JobName -> IO ()
doDelete Database
db
  size :: SQLite -> State -> FuncName -> IO Int64
size           (SQLite db :: Database
db) = Database -> State -> FuncName -> IO Int64
doSize Database
db
  foldr :: SQLite -> State -> (Job -> a -> a) -> a -> IO a
foldr          (SQLite db :: Database
db) = Database -> State -> (Job -> a -> a) -> a -> IO a
forall a. Database -> State -> (Job -> a -> a) -> a -> IO a
doFoldr Database
db
  foldrPending :: SQLite -> Int64 -> [FuncName] -> (Job -> a -> a) -> a -> IO a
foldrPending   (SQLite db :: Database
db) = Database -> Int64 -> [FuncName] -> (Job -> a -> a) -> a -> IO a
forall a.
Database -> Int64 -> [FuncName] -> (Job -> a -> a) -> a -> IO a
doFoldrPending Database
db
  foldrLocking :: SQLite -> Int -> FuncName -> (Job -> a -> a) -> a -> IO a
foldrLocking   (SQLite db :: Database
db) = Database -> Int -> FuncName -> (Job -> a -> a) -> a -> IO a
forall a.
Database -> Int -> FuncName -> (Job -> a -> a) -> a -> IO a
doFoldrLocking Database
db
  dumpJob :: SQLite -> IO [Job]
dumpJob        (SQLite db :: Database
db) = Database -> IO [Job]
doDumpJob Database
db
  configSet :: SQLite -> String -> Int -> IO ()
configSet      (SQLite db :: Database
db) = Database -> String -> Int -> IO ()
doConfigSet Database
db
  configGet :: SQLite -> String -> IO (Maybe Int)
configGet      (SQLite db :: Database
db) = Database -> String -> IO (Maybe Int)
doConfigGet Database
db
  insertFuncName :: SQLite -> FuncName -> IO ()
insertFuncName (SQLite db :: Database
db) = Database -> FuncName -> IO ()
doInsertFuncName Database
db
  removeFuncName :: SQLite -> FuncName -> IO ()
removeFuncName (SQLite db :: Database
db) = Database -> FuncName -> IO ()
doRemoveFuncName Database
db
  funcList :: SQLite -> IO [FuncName]
funcList       (SQLite db :: Database
db) = Database -> IO [FuncName]
doFuncList Database
db
  minSchedAt :: SQLite -> FuncName -> IO Int64
minSchedAt     (SQLite db :: Database
db) = Database -> State -> FuncName -> IO Int64
doMinSchedAt Database
db State
Pending

instance Exception (PersistException SQLite)

instance IsString (PersistConfig SQLite) where
  fromString :: String -> PersistConfig SQLite
fromString = Utf8 -> PersistConfig SQLite
SQLitePath (Utf8 -> PersistConfig SQLite)
-> (String -> Utf8) -> String -> PersistConfig SQLite
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Utf8
forall a. IsString a => String -> a
fromString

beginTx :: Database -> IO ()
beginTx :: Database -> IO ()
beginTx db :: Database
db = IO (Either (Error, Utf8) ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either (Error, Utf8) ()) -> IO ())
-> IO (Either (Error, Utf8) ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Database -> Utf8 -> IO (Either (Error, Utf8) ())
exec Database
db "BEGIN TRANSACTION"

commitTx :: Database -> IO ()
commitTx :: Database -> IO ()
commitTx db :: Database
db = IO (Either (Error, Utf8) ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either (Error, Utf8) ()) -> IO ())
-> IO (Either (Error, Utf8) ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Database -> Utf8 -> IO (Either (Error, Utf8) ())
exec Database
db "COMMIT TRANSACTION"

rollbackTx :: Database -> IO ()
rollbackTx :: Database -> IO ()
rollbackTx db :: Database
db = IO (Either (Error, Utf8) ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either (Error, Utf8) ()) -> IO ())
-> IO (Either (Error, Utf8) ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Database -> Utf8 -> IO (Either (Error, Utf8) ())
exec Database
db "ROLLBACK TRANSACTION"

createConfigTable :: Database -> IO ()
createConfigTable :: Database -> IO ()
createConfigTable db :: Database
db = IO (Either (Error, Utf8) ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either (Error, Utf8) ()) -> IO ())
-> (Utf8 -> IO (Either (Error, Utf8) ())) -> Utf8 -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Database -> Utf8 -> IO (Either (Error, Utf8) ())
exec Database
db (Utf8 -> IO ()) -> Utf8 -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Utf8
Utf8 (ByteString -> Utf8) -> ByteString -> Utf8
forall a b. (a -> b) -> a -> b
$
  "CREATE TABLE IF NOT EXISTS configs ("
    ByteString -> ByteString -> ByteString
`append` "name CHAR(256) NOT NULL,"
    ByteString -> ByteString -> ByteString
`append` "value  INTEGER DEFAULT 0,"
    ByteString -> ByteString -> ByteString
`append` "PRIMARY KEY (name))"

createJobTable :: Database -> IO ()
createJobTable :: Database -> IO ()
createJobTable db :: Database
db = IO (Either (Error, Utf8) ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either (Error, Utf8) ()) -> IO ())
-> (Utf8 -> IO (Either (Error, Utf8) ())) -> Utf8 -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Database -> Utf8 -> IO (Either (Error, Utf8) ())
exec Database
db (Utf8 -> IO ()) -> Utf8 -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Utf8
Utf8 (ByteString -> Utf8) -> ByteString -> Utf8
forall a b. (a -> b) -> a -> b
$
  "CREATE TABLE IF NOT EXISTS jobs ("
    ByteString -> ByteString -> ByteString
`append` " func CHAR(256) NOT NULL,"
    ByteString -> ByteString -> ByteString
`append` " name CHAR(256) NOT NULL,"
    ByteString -> ByteString -> ByteString
`append` " value BLOB,"
    ByteString -> ByteString -> ByteString
`append` " state  INTEGER DEFAULT 0,"
    ByteString -> ByteString -> ByteString
`append` " sched_at INTEGER DEFAULT 0,"
    ByteString -> ByteString -> ByteString
`append` " PRIMARY KEY (func, name))"

createFuncTable :: Database -> IO ()
createFuncTable :: Database -> IO ()
createFuncTable db :: Database
db = IO (Either (Error, Utf8) ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either (Error, Utf8) ()) -> IO ())
-> (Utf8 -> IO (Either (Error, Utf8) ())) -> Utf8 -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Database -> Utf8 -> IO (Either (Error, Utf8) ())
exec Database
db (Utf8 -> IO ()) -> Utf8 -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Utf8
Utf8 (ByteString -> Utf8) -> ByteString -> Utf8
forall a b. (a -> b) -> a -> b
$
  "CREATE TABLE IF NOT EXISTS funcs ("
    ByteString -> ByteString -> ByteString
`append` " func CHAR(256) NOT NULL,"
    ByteString -> ByteString -> ByteString
`append` " PRIMARY KEY (func))"

allPending :: Database -> IO ()
allPending :: Database -> IO ()
allPending db :: Database
db = IO (Either (Error, Utf8) ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either (Error, Utf8) ()) -> IO ())
-> (Utf8 -> IO (Either (Error, Utf8) ())) -> Utf8 -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Database -> Utf8 -> IO (Either (Error, Utf8) ())
exec Database
db (Utf8 -> IO ()) -> Utf8 -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Utf8
Utf8 "UPDATE jobs SET state=0"

doLookup :: Database -> State -> FuncName -> JobName -> IO (Maybe Job)
doLookup :: Database -> State -> FuncName -> JobName -> IO (Maybe Job)
doLookup db :: Database
db state :: State
state fn :: FuncName
fn jn :: JobName
jn =
  [Job] -> Maybe Job
forall a. [a] -> Maybe a
listToMaybe ([Job] -> Maybe Job) -> IO [Job] -> IO (Maybe Job)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Database
-> Utf8
-> (Statement -> IO ())
-> (ByteString -> [Job] -> [Job])
-> [Job]
-> IO [Job]
forall a.
Database
-> Utf8
-> (Statement -> IO ())
-> (ByteString -> a -> a)
-> a
-> IO a
doFoldr_ Database
db Utf8
sql (FuncName -> JobName -> Statement -> IO ()
bindFnAndJn FuncName
fn JobName
jn) ((Job -> [Job] -> [Job]) -> ByteString -> [Job] -> [Job]
forall a. (Job -> a -> a) -> ByteString -> a -> a
mkFoldFunc Job -> [Job] -> [Job]
f) []
  where sql :: Utf8
sql = ByteString -> Utf8
Utf8 (ByteString -> Utf8) -> ByteString -> Utf8
forall a b. (a -> b) -> a -> b
$ "SELECT value FROM jobs WHERE func=? AND name=? AND state=" ByteString -> ByteString -> ByteString
`append` State -> ByteString
stateName State
state ByteString -> ByteString -> ByteString
`append` " LIMIT 1"
        f :: Job -> [Job] -> [Job]
        f :: Job -> [Job] -> [Job]
f job :: Job
job acc :: [Job]
acc = Job
job Job -> [Job] -> [Job]
forall a. a -> [a] -> [a]
: [Job]
acc

doMember :: Database -> State -> FuncName -> JobName -> IO Bool
doMember :: Database -> State -> FuncName -> JobName -> IO Bool
doMember db :: Database
db st :: State
st fn :: FuncName
fn jn :: JobName
jn = Maybe Job -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Job -> Bool) -> IO (Maybe Job) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Database -> State -> FuncName -> JobName -> IO (Maybe Job)
doLookup Database
db State
st FuncName
fn JobName
jn

doInsert :: Database -> State -> FuncName -> JobName -> Job -> IO ()
doInsert :: Database -> State -> FuncName -> JobName -> Job -> IO ()
doInsert db :: Database
db state :: State
state fn :: FuncName
fn jn :: JobName
jn job :: Job
job = do
  Database -> Utf8 -> (Statement -> IO ()) -> IO ()
execStmt Database
db Utf8
sql ((Statement -> IO ()) -> IO ()) -> (Statement -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \stmt :: Statement
stmt -> do
    FuncName -> JobName -> Statement -> IO ()
bindFnAndJn FuncName
fn JobName
jn Statement
stmt
    IO (Either Error ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either Error ()) -> IO ()) -> IO (Either Error ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Statement -> ParamIndex -> ByteString -> IO (Either Error ())
bindBlob  Statement
stmt 3 (ByteString -> IO (Either Error ()))
-> ByteString -> IO (Either Error ())
forall a b. (a -> b) -> a -> b
$ Job -> ByteString
forall a. Byteable a => a -> ByteString
toBytes Job
job
    IO (Either Error ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either Error ()) -> IO ()) -> IO (Either Error ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Statement -> ParamIndex -> Int64 -> IO (Either Error ())
bindInt64 Statement
stmt 4 (Int64 -> IO (Either Error ())) -> Int64 -> IO (Either Error ())
forall a b. (a -> b) -> a -> b
$ State -> Int64
stateName' State
state
    IO (Either Error ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either Error ()) -> IO ()) -> IO (Either Error ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Statement -> ParamIndex -> Int64 -> IO (Either Error ())
bindInt64 Statement
stmt 5 (Int64 -> IO (Either Error ())) -> Int64 -> IO (Either Error ())
forall a b. (a -> b) -> a -> b
$ Job -> Int64
getSchedAt Job
job
  Database -> FuncName -> IO ()
doInsertFuncName Database
db FuncName
fn
  where sql :: Utf8
sql = ByteString -> Utf8
Utf8 "INSERT OR REPLACE INTO jobs VALUES (?, ?, ?, ?, ?)"

doInsertFuncName :: Database -> FuncName -> IO ()
doInsertFuncName :: Database -> FuncName -> IO ()
doInsertFuncName db :: Database
db = Database -> Utf8 -> FuncName -> IO ()
execFN Database
db Utf8
sql
  where sql :: Utf8
sql = ByteString -> Utf8
Utf8 "INSERT OR REPLACE INTO funcs VALUES (?)"

doFoldr :: Database -> State -> (Job -> a -> a) -> a -> IO a
doFoldr :: Database -> State -> (Job -> a -> a) -> a -> IO a
doFoldr db :: Database
db state :: State
state f :: Job -> a -> a
f = Database
-> Utf8
-> (Statement -> IO ())
-> (ByteString -> a -> a)
-> a
-> IO a
forall a.
Database
-> Utf8
-> (Statement -> IO ())
-> (ByteString -> a -> a)
-> a
-> IO a
doFoldr_ Database
db Utf8
sql (IO () -> Statement -> IO ()
forall a b. a -> b -> a
const (IO () -> Statement -> IO ()) -> IO () -> Statement -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) ((Job -> a -> a) -> ByteString -> a -> a
forall a. (Job -> a -> a) -> ByteString -> a -> a
mkFoldFunc Job -> a -> a
f)
  where sql :: Utf8
sql = ByteString -> Utf8
Utf8 (ByteString -> Utf8) -> ByteString -> Utf8
forall a b. (a -> b) -> a -> b
$ "SELECT value FROM jobs WHERE state=" ByteString -> ByteString -> ByteString
`append` State -> ByteString
stateName State
state

doFoldrPending :: Database -> Int64 -> [FuncName] -> (Job -> a -> a) -> a -> IO a
doFoldrPending :: Database -> Int64 -> [FuncName] -> (Job -> a -> a) -> a -> IO a
doFoldrPending db :: Database
db ts :: Int64
ts fns :: [FuncName]
fns f :: Job -> a -> a
f acc :: a
acc = (FuncName -> a -> IO a) -> a -> [FuncName] -> IO a
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
F.foldrM ((Job -> a -> a) -> FuncName -> a -> IO a
forall a. (Job -> a -> a) -> FuncName -> a -> IO a
foldFunc Job -> a -> a
f) a
acc [FuncName]
fns
  where sql :: Utf8
sql = ByteString -> Utf8
Utf8 (ByteString -> Utf8) -> ByteString -> Utf8
forall a b. (a -> b) -> a -> b
$ "SELECT value FROM jobs WHERE func=? AND state="
                   ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> State -> ByteString
stateName State
Pending
                   ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> " AND sched_at<"
                   ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> String -> ByteString
B.pack (Int64 -> String
forall a. Show a => a -> String
show Int64
ts)

        foldFunc :: (Job -> a -> a) -> FuncName -> a -> IO a
        foldFunc :: (Job -> a -> a) -> FuncName -> a -> IO a
foldFunc  f0 :: Job -> a -> a
f0 fn :: FuncName
fn =
          Database
-> Utf8
-> (Statement -> IO ())
-> (ByteString -> a -> a)
-> a
-> IO a
forall a.
Database
-> Utf8
-> (Statement -> IO ())
-> (ByteString -> a -> a)
-> a
-> IO a
doFoldr_ Database
db Utf8
sql (Statement -> FuncName -> IO ()
`bindFN` FuncName
fn) ((Job -> a -> a) -> ByteString -> a -> a
forall a. (Job -> a -> a) -> ByteString -> a -> a
mkFoldFunc Job -> a -> a
f0)

doFoldrLocking :: Database -> Int -> FuncName -> (Job -> a -> a) -> a -> IO a
doFoldrLocking :: Database -> Int -> FuncName -> (Job -> a -> a) -> a -> IO a
doFoldrLocking db :: Database
db limit :: Int
limit fn :: FuncName
fn f :: Job -> a -> a
f = Database
-> Utf8
-> (Statement -> IO ())
-> (ByteString -> a -> a)
-> a
-> IO a
forall a.
Database
-> Utf8
-> (Statement -> IO ())
-> (ByteString -> a -> a)
-> a
-> IO a
doFoldr_ Database
db Utf8
sql (Statement -> FuncName -> IO ()
`bindFN` FuncName
fn) ((Job -> a -> a) -> ByteString -> a -> a
forall a. (Job -> a -> a) -> ByteString -> a -> a
mkFoldFunc Job -> a -> a
f)
  where sql :: Utf8
sql = ByteString -> Utf8
Utf8 (ByteString -> Utf8) -> ByteString -> Utf8
forall a b. (a -> b) -> a -> b
$ "SELECT value FROM jobs WHERE func=? AND state="
                   ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> State -> ByteString
stateName State
Locking
                   ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> " ORDER BY sched_at ASC LIMIT " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> String -> ByteString
B.pack (Int -> String
forall a. Show a => a -> String
show Int
limit)

doDumpJob :: Database -> IO [Job]
doDumpJob :: Database -> IO [Job]
doDumpJob db :: Database
db = Database
-> Utf8
-> (Statement -> IO ())
-> (ByteString -> [Job] -> [Job])
-> [Job]
-> IO [Job]
forall a.
Database
-> Utf8
-> (Statement -> IO ())
-> (ByteString -> a -> a)
-> a
-> IO a
doFoldr_ Database
db Utf8
sql (IO () -> Statement -> IO ()
forall a b. a -> b -> a
const (IO () -> Statement -> IO ()) -> IO () -> Statement -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) ((Job -> [Job] -> [Job]) -> ByteString -> [Job] -> [Job]
forall a. (Job -> a -> a) -> ByteString -> a -> a
mkFoldFunc (:)) []
  where sql :: Utf8
sql = ByteString -> Utf8
Utf8 "SELECT value FROM jobs"

doFuncList :: Database -> IO [FuncName]
doFuncList :: Database -> IO [FuncName]
doFuncList db :: Database
db =
  Database
-> Utf8
-> (Statement -> IO ())
-> (ByteString -> [FuncName] -> [FuncName])
-> [FuncName]
-> IO [FuncName]
forall a.
Database
-> Utf8
-> (Statement -> IO ())
-> (ByteString -> a -> a)
-> a
-> IO a
doFoldr_ Database
db Utf8
sql (IO () -> Statement -> IO ()
forall a b. a -> b -> a
const (IO () -> Statement -> IO ()) -> IO () -> Statement -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (\fn :: ByteString
fn acc :: [FuncName]
acc -> ByteString -> FuncName
FuncName ByteString
fn FuncName -> [FuncName] -> [FuncName]
forall a. a -> [a] -> [a]
: [FuncName]
acc) []
  where sql :: Utf8
sql = ByteString -> Utf8
Utf8 "SELECT func FROM funcs"

doDelete :: Database -> FuncName -> JobName -> IO ()
doDelete :: Database -> FuncName -> JobName -> IO ()
doDelete db :: Database
db fn :: FuncName
fn jn :: JobName
jn = Database -> Utf8 -> (Statement -> IO ()) -> IO ()
execStmt Database
db Utf8
sql ((Statement -> IO ()) -> IO ()) -> (Statement -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ FuncName -> JobName -> Statement -> IO ()
bindFnAndJn FuncName
fn JobName
jn
  where sql :: Utf8
sql = ByteString -> Utf8
Utf8 "DELETE FROM jobs WHERE func=? AND name=?"

doRemoveFuncName :: Database -> FuncName -> IO ()
doRemoveFuncName :: Database -> FuncName -> IO ()
doRemoveFuncName db :: Database
db fn :: FuncName
fn = do
  Database -> Utf8 -> FuncName -> IO ()
execFN Database
db Utf8
sql0 FuncName
fn
  Database -> Utf8 -> FuncName -> IO ()
execFN Database
db Utf8
sql1 FuncName
fn

  where sql0 :: Utf8
sql0 = ByteString -> Utf8
Utf8 "DELETE FROM funcs WHERE func=?"
        sql1 :: Utf8
sql1 = ByteString -> Utf8
Utf8 "DELETE FROM jobs WHERE func=?"

doMinSchedAt :: Database -> State -> FuncName -> IO Int64
doMinSchedAt :: Database -> State -> FuncName -> IO Int64
doMinSchedAt db :: Database
db state :: State
state fn :: FuncName
fn = Database
-> Utf8
-> (Statement -> IO ())
-> (Statement -> IO Int64)
-> IO Int64
forall a.
Database
-> Utf8 -> (Statement -> IO ()) -> (Statement -> IO a) -> IO a
queryStmt Database
db Utf8
sql (Statement -> FuncName -> IO ()
`bindFN` FuncName
fn) Statement -> IO Int64
stepInt64
  where sql :: Utf8
sql = ByteString -> Utf8
Utf8 (ByteString -> Utf8) -> ByteString -> Utf8
forall a b. (a -> b) -> a -> b
$ "SELECT sched_at FROM jobs WHERE func=? AND state=" ByteString -> ByteString -> ByteString
`append` State -> ByteString
stateName State
state ByteString -> ByteString -> ByteString
`append` " ORDER BY sched_at ASC LIMIT 1"

doSize :: Database -> State -> FuncName -> IO Int64
doSize :: Database -> State -> FuncName -> IO Int64
doSize db :: Database
db state :: State
state fn :: FuncName
fn = Database
-> Utf8
-> (Statement -> IO ())
-> (Statement -> IO Int64)
-> IO Int64
forall a.
Database
-> Utf8 -> (Statement -> IO ()) -> (Statement -> IO a) -> IO a
queryStmt Database
db Utf8
sql (Statement -> FuncName -> IO ()
`bindFN` FuncName
fn) Statement -> IO Int64
stepInt64
  where sql :: Utf8
sql = ByteString -> Utf8
Utf8 (ByteString -> Utf8) -> ByteString -> Utf8
forall a b. (a -> b) -> a -> b
$ "SELECT COUNT(*) FROM jobs WHERE func=? AND state=" ByteString -> ByteString -> ByteString
`append` State -> ByteString
stateName State
state

doConfigSet :: Database -> String -> Int -> IO ()
doConfigSet :: Database -> String -> Int -> IO ()
doConfigSet db :: Database
db name :: String
name v :: Int
v = Database -> Utf8 -> (Statement -> IO ()) -> IO ()
execStmt Database
db Utf8
sql ((Statement -> IO ()) -> IO ()) -> (Statement -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \stmt :: Statement
stmt -> do
    IO (Either Error ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either Error ()) -> IO ()) -> IO (Either Error ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Statement -> ParamIndex -> Utf8 -> IO (Either Error ())
bindText Statement
stmt 1 (Utf8 -> IO (Either Error ())) -> Utf8 -> IO (Either Error ())
forall a b. (a -> b) -> a -> b
$ String -> Utf8
forall a. IsString a => String -> a
fromString String
name
    IO (Either Error ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either Error ()) -> IO ()) -> IO (Either Error ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Statement -> ParamIndex -> Int64 -> IO (Either Error ())
bindInt64 Statement
stmt 2 (Int64 -> IO (Either Error ())) -> Int64 -> IO (Either Error ())
forall a b. (a -> b) -> a -> b
$ Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
v
  where sql :: Utf8
sql = ByteString -> Utf8
Utf8 "INSERT OR REPLACE INTO configs VALUES (?,?)"

doConfigGet :: Database -> String -> IO (Maybe Int)
doConfigGet :: Database -> String -> IO (Maybe Int)
doConfigGet db :: Database
db name :: String
name = Database
-> Utf8
-> (Statement -> IO ())
-> (Statement -> IO (Maybe Int))
-> IO (Maybe Int)
forall a.
Database
-> Utf8 -> (Statement -> IO ()) -> (Statement -> IO a) -> IO a
queryStmt Database
db Utf8
sql (\stmt :: Statement
stmt -> IO (Either Error ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either Error ()) -> IO ()) -> IO (Either Error ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Statement -> ParamIndex -> Utf8 -> IO (Either Error ())
bindText Statement
stmt 1 (Utf8 -> IO (Either Error ())) -> Utf8 -> IO (Either Error ())
forall a b. (a -> b) -> a -> b
$ String -> Utf8
forall a. IsString a => String -> a
fromString String
name) Statement -> IO (Maybe Int)
stepMaybeInt
  where sql :: Utf8
sql = ByteString -> Utf8
Utf8 "SELECT value FROM configs WHERE name=?"

dbError :: String -> IO a
dbError :: String -> IO a
dbError = IOError -> IO a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (IOError -> IO a) -> (String -> IOError) -> String -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IOError
userError (String -> IOError) -> ShowS -> String -> IOError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ("Database error: " String -> ShowS
forall a. [a] -> [a] -> [a]
++)

liftEither :: Show a => IO (Either a b) -> IO b
liftEither :: IO (Either a b) -> IO b
liftEither a :: IO (Either a b)
a = do
  Either a b
er <- IO (Either a b)
a
  case Either a b
er of
    (Left e :: a
e)  -> String -> IO b
forall a. String -> IO a
dbError (a -> String
forall a. Show a => a -> String
show a
e)
    (Right r :: b
r) -> b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
r
{-# INLINE liftEither #-}

prepStmt :: Database -> Utf8 -> IO Statement
prepStmt :: Database -> Utf8 -> IO Statement
prepStmt c :: Database
c q :: Utf8
q = do
    Either Error (Maybe Statement)
r <- Database -> Utf8 -> IO (Either Error (Maybe Statement))
prepare Database
c Utf8
q
    case Either Error (Maybe Statement)
r of
      Left e :: Error
e         -> String -> IO Statement
forall a. String -> IO a
dbError (Error -> String
forall a. Show a => a -> String
show Error
e)
      Right Nothing  -> String -> IO Statement
forall a. String -> IO a
dbError "Statement prep failed"
      Right (Just s :: Statement
s) -> Statement -> IO Statement
forall (m :: * -> *) a. Monad m => a -> m a
return Statement
s

bindFN :: Statement -> FuncName -> IO ()
bindFN :: Statement -> FuncName -> IO ()
bindFN stmt :: Statement
stmt (FuncName fn :: ByteString
fn) = IO (Either Error ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either Error ()) -> IO ()) -> IO (Either Error ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Statement -> ParamIndex -> ByteString -> IO (Either Error ())
bindBlob Statement
stmt 1 ByteString
fn

execStmt :: Database -> Utf8 -> (Statement -> IO ()) -> IO ()
execStmt :: Database -> Utf8 -> (Statement -> IO ()) -> IO ()
execStmt db :: Database
db sql :: Utf8
sql bindStmt :: Statement -> IO ()
bindStmt = do
  Statement
stmt <- Database -> Utf8 -> IO Statement
prepStmt Database
db Utf8
sql
  Statement -> IO ()
bindStmt Statement
stmt
  IO StepResult -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO StepResult -> IO ()) -> IO StepResult -> IO ()
forall a b. (a -> b) -> a -> b
$ IO (Either Error StepResult) -> IO StepResult
forall a b. Show a => IO (Either a b) -> IO b
liftEither (IO (Either Error StepResult) -> IO StepResult)
-> IO (Either Error StepResult) -> IO StepResult
forall a b. (a -> b) -> a -> b
$ Statement -> IO (Either Error StepResult)
step Statement
stmt
  IO (Either Error ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either Error ()) -> IO ()) -> IO (Either Error ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Statement -> IO (Either Error ())
finalize Statement
stmt

execFN :: Database -> Utf8 -> FuncName -> IO ()
execFN :: Database -> Utf8 -> FuncName -> IO ()
execFN db :: Database
db sql :: Utf8
sql fn :: FuncName
fn = Database -> Utf8 -> (Statement -> IO ()) -> IO ()
execStmt Database
db Utf8
sql (Statement -> FuncName -> IO ()
`bindFN` FuncName
fn)

queryStmt :: Database -> Utf8 -> (Statement -> IO ()) -> (Statement -> IO a) -> IO a
queryStmt :: Database
-> Utf8 -> (Statement -> IO ()) -> (Statement -> IO a) -> IO a
queryStmt db :: Database
db sql :: Utf8
sql bindStmt :: Statement -> IO ()
bindStmt stepStmt :: Statement -> IO a
stepStmt = do
  Statement
stmt <- Database -> Utf8 -> IO Statement
prepStmt Database
db Utf8
sql
  Statement -> IO ()
bindStmt Statement
stmt
  a
ret <- Statement -> IO a
stepStmt Statement
stmt
  IO (Either Error ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either Error ()) -> IO ()) -> IO (Either Error ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Statement -> IO (Either Error ())
finalize Statement
stmt
  a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
ret

bindFnAndJn :: FuncName -> JobName -> Statement -> IO ()
bindFnAndJn :: FuncName -> JobName -> Statement -> IO ()
bindFnAndJn fn :: FuncName
fn (JobName jn :: ByteString
jn) stmt :: Statement
stmt = do
  Statement -> FuncName -> IO ()
bindFN Statement
stmt FuncName
fn
  IO (Either Error ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either Error ()) -> IO ()) -> IO (Either Error ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Statement -> ParamIndex -> ByteString -> IO (Either Error ())
bindBlob Statement
stmt 2 ByteString
jn

mkFoldFunc :: (Job -> a -> a) -> ByteString -> a -> a
mkFoldFunc :: (Job -> a -> a) -> ByteString -> a -> a
mkFoldFunc f :: Job -> a -> a
f bs :: ByteString
bs acc :: a
acc =
  case ByteString
-> Either (ByteString, Int64, String) (ByteString, Int64, Job)
forall a.
Binary a =>
ByteString
-> Either (ByteString, Int64, String) (ByteString, Int64, a)
decodeOrFail (ByteString -> ByteString
fromStrict ByteString
bs) of
    Left _            -> a
acc
    Right (_, _, job :: Job
job) -> Job -> a -> a
f Job
job a
acc

foldStmt :: (ByteString -> a -> a) -> a -> Statement -> IO a
foldStmt :: (ByteString -> a -> a) -> a -> Statement -> IO a
foldStmt f :: ByteString -> a -> a
f acc :: a
acc stmt :: Statement
stmt = do
  StepResult
sr <- IO (Either Error StepResult) -> IO StepResult
forall a b. Show a => IO (Either a b) -> IO b
liftEither (IO (Either Error StepResult) -> IO StepResult)
-> IO (Either Error StepResult) -> IO StepResult
forall a b. (a -> b) -> a -> b
$ Statement -> IO (Either Error StepResult)
step Statement
stmt
  case StepResult
sr of
    Done -> a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
acc
    Row -> do
      ByteString
bs <- Statement -> ColumnIndex -> IO ByteString
columnBlob Statement
stmt 0
      (ByteString -> a -> a) -> a -> Statement -> IO a
forall a. (ByteString -> a -> a) -> a -> Statement -> IO a
foldStmt ByteString -> a -> a
f (ByteString -> a -> a
f ByteString
bs a
acc) Statement
stmt

doFoldr_ :: Database -> Utf8 -> (Statement -> IO ()) -> (ByteString -> a -> a) -> a -> IO a
doFoldr_ :: Database
-> Utf8
-> (Statement -> IO ())
-> (ByteString -> a -> a)
-> a
-> IO a
doFoldr_ db :: Database
db sql :: Utf8
sql bindStmt :: Statement -> IO ()
bindStmt f :: ByteString -> a -> a
f acc :: a
acc = Database
-> Utf8 -> (Statement -> IO ()) -> (Statement -> IO a) -> IO a
forall a.
Database
-> Utf8 -> (Statement -> IO ()) -> (Statement -> IO a) -> IO a
queryStmt Database
db Utf8
sql Statement -> IO ()
bindStmt ((Statement -> IO a) -> IO a) -> (Statement -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ (ByteString -> a -> a) -> a -> Statement -> IO a
forall a. (ByteString -> a -> a) -> a -> Statement -> IO a
foldStmt ByteString -> a -> a
f a
acc

stepInt64 :: Statement -> IO Int64
stepInt64 :: Statement -> IO Int64
stepInt64 stmt :: Statement
stmt = do
  StepResult
sr <- IO (Either Error StepResult) -> IO StepResult
forall a b. Show a => IO (Either a b) -> IO b
liftEither (IO (Either Error StepResult) -> IO StepResult)
-> IO (Either Error StepResult) -> IO StepResult
forall a b. (a -> b) -> a -> b
$ Statement -> IO (Either Error StepResult)
step Statement
stmt

  case StepResult
sr of
    Done -> Int64 -> IO Int64
forall (f :: * -> *) a. Applicative f => a -> f a
pure 0
    Row  -> Statement -> ColumnIndex -> IO Int64
columnInt64 Statement
stmt 0

stepMaybeInt :: Statement -> IO (Maybe Int)
stepMaybeInt :: Statement -> IO (Maybe Int)
stepMaybeInt stmt :: Statement
stmt = do
  StepResult
sr <- IO (Either Error StepResult) -> IO StepResult
forall a b. Show a => IO (Either a b) -> IO b
liftEither (IO (Either Error StepResult) -> IO StepResult)
-> IO (Either Error StepResult) -> IO StepResult
forall a b. (a -> b) -> a -> b
$ Statement -> IO (Either Error StepResult)
step Statement
stmt
  case StepResult
sr of
    Done -> Maybe Int -> IO (Maybe Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Int
forall a. Maybe a
Nothing
    Row  -> Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> (Int64 -> Int) -> Int64 -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Maybe Int) -> IO Int64 -> IO (Maybe Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Statement -> ColumnIndex -> IO Int64
columnInt64 Statement
stmt 0