never executed always true always false
    1 {-|
    2 Module: Flaw.Oil.Repo
    3 Description: General repo functions.
    4 License: MIT
    5 -}
    6 
    7 {-# LANGUAGE DeriveGeneric #-}
    8 
    9 module Flaw.Oil.Repo
   10   ( RepoVersion(..)
   11   , serverRepoVersion
   12   , clientRepoVersion
   13   , Manifest(..)
   14   , protocolVersion
   15   , defaultManifest
   16   , openRepoDb
   17   , Revision
   18   , UserId
   19   , Push(..)
   20   , Pull(..)
   21   , checkPushLimits
   22   , SyncError(..)
   23   , Repo(..)
   24   , repoDbCheckIntegrity
   25   , repoDbVacuum
   26   ) where
   27 
   28 import Control.Exception
   29 import Control.Monad
   30 import qualified Data.ByteString as B
   31 import Data.Foldable
   32 import Data.Int
   33 import qualified Data.Serialize as S
   34 import qualified Data.Text as T
   35 import Foreign.C.Types
   36 import GHC.Generics
   37 
   38 import Flaw.Book
   39 import Flaw.Data.Sqlite
   40 import Flaw.Exception
   41 
   42 newtype RepoVersion = RepoVersion CInt
   43 
   44 -- | "application_id" in SQLite db of server repo.
   45 -- Convention: oil<letter starting from A> in little-endian.
   46 serverRepoVersion :: RepoVersion
   47 serverRepoVersion = RepoVersion 0x416c696f -- "oilA"
   48 
   49 -- | "application_id" in SQLite db of client repo.
   50 -- Convention: oil<letter starting from a> in little-endian.
   51 clientRepoVersion :: RepoVersion
   52 clientRepoVersion = RepoVersion 0x616c696f -- "oila"
   53 
   54 -- | Manifest with most limitations.
   55 data Manifest = Manifest
   56   { manifestProtocolVersion :: !Int32
   57   , manifestMaxKeySize :: !Int
   58   , manifestMaxValueSize :: !Int
   59   , manifestMaxPushItemsCount :: !Int
   60   , manifestMaxPushValuesTotalSize :: !Int
   61   , manifestMaxPullItemsCount :: !Int
   62   , manifestMaxPullValuesTotalSize :: !Int
   63   } deriving Generic
   64 
   65 instance S.Serialize Manifest
   66 
   67 -- | Current protocol version.
   68 -- Convention: oil<digit starting from 0> in little-endian.
   69 protocolVersion :: Int32
   70 protocolVersion = 0x306c696f -- "oil0"
   71 
   72 defaultManifest :: Manifest
   73 defaultManifest = Manifest
   74   { manifestProtocolVersion = protocolVersion
   75   , manifestMaxKeySize = 128
   76   , manifestMaxValueSize = 1024 * 1024
   77   , manifestMaxPushItemsCount = 1024
   78   , manifestMaxPushValuesTotalSize = 1024 * 1024 * 2
   79   , manifestMaxPullItemsCount = 1024
   80   , manifestMaxPullValuesTotalSize = 1024 * 1024 * 2
   81   }
   82 
   83 openRepoDb :: T.Text -> RepoVersion -> IO (SqliteDb, IO ())
   84 openRepoDb fileName (RepoVersion version) = withSpecialBook $ \bk -> do
   85   -- open db
   86   db <- book bk $ sqliteDb fileName
   87 
   88   -- enable exclusive locking mode
   89   sqliteExec db $ T.pack "PRAGMA locking_mode = EXCLUSIVE"
   90   -- enable WAL journal mode
   91   sqliteExec db $ T.pack "PRAGMA journal_mode = WAL"
   92 
   93   -- check version
   94   withBook $ \tempBk -> do
   95     stmt <- book tempBk $ sqliteStmt db $ T.pack "PRAGMA application_id"
   96     sqliteQuery stmt $ \query -> do
   97       r <- sqliteStep query
   98       unless r $ throwIO $ DescribeFirstException "failed to get application_id"
   99       currentAppVersion <- sqliteColumn query 0
  100       -- if version is not set yet
  101       if currentAppVersion == 0 then
  102         -- set it
  103         sqliteExec db $ T.pack $ "PRAGMA application_id = " ++ show version
  104       -- else check that version is correct
  105       else when (currentAppVersion /= version) $ throwIO $ DescribeFirstException "wrong application_id"
  106 
  107   return db
  108 
  109 -- | Type for revisions.
  110 -- Start revision is 1. 0 means no revisions.
  111 type Revision = Int64
  112 
  113 -- | Type for user ID.
  114 type UserId = Int64
  115 
  116 -- | Data sent by client to server.
  117 data Push = Push
  118   {
  119   -- | Current revision of the client.
  120     pushClientRevision :: !Revision
  121   -- | Upper bound on revisions server may send to client.
  122   -- Used to prevent sending revisions client already knows about.
  123   , pushClientUpperRevision :: !Revision
  124   -- | Pushed (key, value) pairs.
  125   , pushItems :: [(B.ByteString, B.ByteString)]
  126   } deriving Generic
  127 
  128 instance S.Serialize Push
  129 
  130 -- | Data sent by server to client.
  131 data Pull = Pull
  132   {
  133   -- | Total number of revisions client needs to pull in order to catch up with server, counting from pushClientRevision
  134     pullLag :: !Int64
  135   -- | Server revision before pushing items.
  136   , pullPrePushRevision :: !Revision
  137   -- | Server revision after pushing items (should be equal to pre-push revision + number of items pushed).
  138   , pullPostPushRevision :: !Revision
  139   -- | Pairs (key, value) to pull.
  140   , pullItems :: [(Revision, B.ByteString, B.ByteString)]
  141   -- | New client revision after whole operation.
  142   , pullNewClientRevision :: !Revision
  143   } deriving Generic
  144 
  145 instance S.Serialize Pull
  146 
  147 -- | Check push limits.
  148 checkPushLimits :: Manifest -> Push -> Maybe SyncError
  149 checkPushLimits Manifest
  150   { manifestMaxKeySize = maxKeySize
  151   , manifestMaxValueSize = maxValueSize
  152   , manifestMaxPushItemsCount = maxPushItemsCount
  153   , manifestMaxPushValuesTotalSize = maxPushValuesTotalSize
  154   } Push
  155   { pushItems = items
  156   } = maybeError where
  157   maybeError =
  158     if length items > maxPushItemsCount then Just SyncTooManyItemsError
  159     else case foldrM f 0 items of
  160       Right _valuesTotalSize -> Nothing
  161       Left err -> Just err
  162   f (key, value) valuesTotalSize
  163     | B.length key > maxKeySize = Left SyncTooBigKeyError
  164     | B.length value > maxValueSize = Left SyncTooBigValueError
  165     | otherwise = let newValuesTotalSize = valuesTotalSize + B.length value in
  166       if newValuesTotalSize > maxPushValuesTotalSize then Left SyncTooBigPushValuesTotalSize
  167       else Right newValuesTotalSize
  168 
  169 -- | Errors while syncing (reported to client).
  170 data SyncError
  171   = SyncTooManyItemsError
  172   | SyncTooBigKeyError
  173   | SyncTooBigValueError
  174   | SyncTooBigPushValuesTotalSize
  175   | SyncFatalError
  176   deriving Generic
  177 
  178 class Repo r where
  179   -- | Get SQLite DB.
  180   repoDb :: r -> SqliteDb
  181 
  182 -- | Check integrity of DB.
  183 repoDbCheckIntegrity :: SqliteDb -> IO (Bool, T.Text)
  184 repoDbCheckIntegrity db = withBook $ \bk -> do
  185   stmt <- book bk $ sqliteStmt db $ T.pack "PRAGMA integrity_check"
  186   lns <- sqliteQuery stmt $ \query -> do
  187     let
  188       step = do
  189         r <- sqliteStep query
  190         if r then do
  191           line <- sqliteColumn query 0
  192           restLines <- step
  193           return $ line : restLines
  194         else return []
  195       in step
  196   return (lns == [T.pack "ok"], T.unlines lns)
  197 
  198 -- | Optimize DB.
  199 repoDbVacuum :: SqliteDb -> IO ()
  200 repoDbVacuum db = sqliteExec db $ T.pack "VACUUM"