{-# 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