{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE RecordWildCards #-}

-- |Data structure, serialization, and file i/o for @strfile@-style index files
-- 
-- The old @strfile@ \"format\" has some serious funkiness, especially on 64-bit systems.
-- This is a saner implementation of the same concept.
--
-- The file format is as follows:
-- 
-- section | offset | format    | description
-- ========|========| ==========|==============
-- header  |      0 | word32be  | Magic number (0xbdcbcdb, a hard-to-type base-16 palindromic prime)
--         |      4 | word32be  | Version number (currently 2)
--         |      8 | word32be  | Offset of string table in index file
--         |     12 | word32be  | Number of entries in string table
--         |     16 | word32be  | Maximum number of chars in a string
--         |     20 | word32be  | Minimum number of chars in a string
--         |     24 | word32be  | Maximum number of lines in a string
--         |     28 | word32be  | Minimum number of lines in a string
--         |     32 | word32be  | Offset in string file after last char of last fortune
--         |     36 | 28 bytes  | reserved (set to 0 when not in use)
-- ========|========| ==========|==============
-- table   |     ?? | entry*    | Offset given in header.  Format given below.
--
-- entries are 16 bytes each, and consist of:
-- 
-- offset | format   | description
-- =======|==========|==============
--      0 | word32be | byte offset of string in file
--      4 | word32be | byte length of string in file
--      8 | word32be | number of characters in string
--     12 | word32be | number of lines in string
module Data.Fortune.Index
     ( Index
     , openIndex
     , createVirtualIndex
     , closeIndex
     , getStats
     
     , StatsProblem(..)
     , HeaderProblem(..)
     , IndexProblem(..)
     , checkIndex
     
     , IndexEntry(..)
     , indexEntryStats
     , getEntries
     , getEntry
     , unfoldEntries
     , appendEntries
     , appendEntry
     , clearIndex
     , rebuildStats
     ) where

import Control.Concurrent.MVar
import Control.Exception
import Control.Monad
import qualified Data.ByteString as BS
import Data.Fortune.Stats
import Data.Knob
import Data.Maybe
import Data.Semigroup
import Data.Serialize
import Data.Typeable
import qualified Data.Vector as V
import Data.Word
import System.IO

runGetM :: Get a -> ByteString -> m a
runGetM Get a
getThing = (String -> m a) -> (a -> m a) -> Either String a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String a -> m a)
-> (ByteString -> Either String a) -> ByteString -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Get a -> ByteString -> Either String a
forall a. Get a -> ByteString -> Either String a
runGet Get a
getThing

magic, currentVersion :: Word32
magic :: Word32
magic                   = Word32
0xbdcbcdb
currentVersion :: Word32
currentVersion          = Word32
2

headerLength :: Int
headerLength            = Int
64 -- bytes
headerReservedLength :: Int
headerReservedLength    = Int
28 -- bytes

data Header = Header
    { Header -> FortuneStats
stats     :: !FortuneStats
    , Header -> Int
indexLoc  :: !Int
    } deriving (Header -> Header -> Bool
(Header -> Header -> Bool)
-> (Header -> Header -> Bool) -> Eq Header
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Header -> Header -> Bool
$c/= :: Header -> Header -> Bool
== :: Header -> Header -> Bool
$c== :: Header -> Header -> Bool
Eq, Int -> Header -> ShowS
[Header] -> ShowS
Header -> String
(Int -> Header -> ShowS)
-> (Header -> String) -> ([Header] -> ShowS) -> Show Header
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Header] -> ShowS
$cshowList :: [Header] -> ShowS
show :: Header -> String
$cshow :: Header -> String
showsPrec :: Int -> Header -> ShowS
$cshowsPrec :: Int -> Header -> ShowS
Show)

emptyHeader :: Header
emptyHeader = FortuneStats -> Int -> Header
Header FortuneStats
forall a. Monoid a => a
mempty Int
headerLength

-- |An exception type indicating things that can be wrong about an index file's header.
data HeaderProblem
    = BadMagicNumber !Word32
    | UnsupportedVersion !Word32
    | StatsProblem !StatsProblem
    | TableStartsBeforeHeaderEnds
    deriving (HeaderProblem -> HeaderProblem -> Bool
(HeaderProblem -> HeaderProblem -> Bool)
-> (HeaderProblem -> HeaderProblem -> Bool) -> Eq HeaderProblem
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HeaderProblem -> HeaderProblem -> Bool
$c/= :: HeaderProblem -> HeaderProblem -> Bool
== :: HeaderProblem -> HeaderProblem -> Bool
$c== :: HeaderProblem -> HeaderProblem -> Bool
Eq, Eq HeaderProblem
Eq HeaderProblem
-> (HeaderProblem -> HeaderProblem -> Ordering)
-> (HeaderProblem -> HeaderProblem -> Bool)
-> (HeaderProblem -> HeaderProblem -> Bool)
-> (HeaderProblem -> HeaderProblem -> Bool)
-> (HeaderProblem -> HeaderProblem -> Bool)
-> (HeaderProblem -> HeaderProblem -> HeaderProblem)
-> (HeaderProblem -> HeaderProblem -> HeaderProblem)
-> Ord HeaderProblem
HeaderProblem -> HeaderProblem -> Bool
HeaderProblem -> HeaderProblem -> Ordering
HeaderProblem -> HeaderProblem -> HeaderProblem
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: HeaderProblem -> HeaderProblem -> HeaderProblem
$cmin :: HeaderProblem -> HeaderProblem -> HeaderProblem
max :: HeaderProblem -> HeaderProblem -> HeaderProblem
$cmax :: HeaderProblem -> HeaderProblem -> HeaderProblem
>= :: HeaderProblem -> HeaderProblem -> Bool
$c>= :: HeaderProblem -> HeaderProblem -> Bool
> :: HeaderProblem -> HeaderProblem -> Bool
$c> :: HeaderProblem -> HeaderProblem -> Bool
<= :: HeaderProblem -> HeaderProblem -> Bool
$c<= :: HeaderProblem -> HeaderProblem -> Bool
< :: HeaderProblem -> HeaderProblem -> Bool
$c< :: HeaderProblem -> HeaderProblem -> Bool
compare :: HeaderProblem -> HeaderProblem -> Ordering
$ccompare :: HeaderProblem -> HeaderProblem -> Ordering
$cp1Ord :: Eq HeaderProblem
Ord, ReadPrec [HeaderProblem]
ReadPrec HeaderProblem
Int -> ReadS HeaderProblem
ReadS [HeaderProblem]
(Int -> ReadS HeaderProblem)
-> ReadS [HeaderProblem]
-> ReadPrec HeaderProblem
-> ReadPrec [HeaderProblem]
-> Read HeaderProblem
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [HeaderProblem]
$creadListPrec :: ReadPrec [HeaderProblem]
readPrec :: ReadPrec HeaderProblem
$creadPrec :: ReadPrec HeaderProblem
readList :: ReadS [HeaderProblem]
$creadList :: ReadS [HeaderProblem]
readsPrec :: Int -> ReadS HeaderProblem
$creadsPrec :: Int -> ReadS HeaderProblem
Read, Int -> HeaderProblem -> ShowS
[HeaderProblem] -> ShowS
HeaderProblem -> String
(Int -> HeaderProblem -> ShowS)
-> (HeaderProblem -> String)
-> ([HeaderProblem] -> ShowS)
-> Show HeaderProblem
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HeaderProblem] -> ShowS
$cshowList :: [HeaderProblem] -> ShowS
show :: HeaderProblem -> String
$cshow :: HeaderProblem -> String
showsPrec :: Int -> HeaderProblem -> ShowS
$cshowsPrec :: Int -> HeaderProblem -> ShowS
Show, Typeable)

checkHeader :: Header -> Maybe HeaderProblem
checkHeader (Header FortuneStats
stats Int
loc)
    | Int
loc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
headerLength    = HeaderProblem -> Maybe HeaderProblem
forall a. a -> Maybe a
Just HeaderProblem
TableStartsBeforeHeaderEnds
    | Bool
otherwise             = StatsProblem -> HeaderProblem
StatsProblem (StatsProblem -> HeaderProblem)
-> Maybe StatsProblem -> Maybe HeaderProblem
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FortuneStats -> Maybe StatsProblem
checkStats FortuneStats
stats

knownVersions :: [(Word32, Get Header)]
knownVersions = [(Word32
currentVersion, Get Header
getRestV2)]

getHeader :: Get Header
getHeader = do
    Word32
n <- Get Word32
getWord32be
    Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word32
n Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word32
magic) (Get () -> Get ()) -> Get () -> Get ()
forall a b. (a -> b) -> a -> b
$ HeaderProblem -> Get ()
forall a e. Exception e => e -> a
throw (Word32 -> HeaderProblem
BadMagicNumber Word32
n)
    Word32
version <- Get Word32
getWord32be
    case Word32 -> [(Word32, Get Header)] -> Maybe (Get Header)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Word32
version [(Word32, Get Header)]
knownVersions of
        Just Get Header
getRest -> Get Header
getRest
        Maybe (Get Header)
Nothing      -> HeaderProblem -> Get Header
forall a e. Exception e => e -> a
throw (Word32 -> HeaderProblem
UnsupportedVersion Word32
version)

getRestV2 :: Get Header
getRestV2 = do
    Int
indexLoc    <-       Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Get Word32 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32be
    Sum Int
numFortunes <- Int -> Sum Int
forall a. a -> Sum a
Sum (Int -> Sum Int) -> (Word32 -> Int) -> Word32 -> Sum Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Sum Int) -> Get Word32 -> Get (Sum Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32be
    Max Int
maxChars    <- Int -> Max Int
forall a. a -> Max a
Max (Int -> Max Int) -> (Word32 -> Int) -> Word32 -> Max Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Max Int) -> Get Word32 -> Get (Max Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32be
    Min Int
minChars    <- Int -> Min Int
forall a. a -> Min a
Min (Int -> Min Int) -> (Word32 -> Int) -> Word32 -> Min Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Min Int) -> Get Word32 -> Get (Min Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32be
    Max Int
maxLines    <- Int -> Max Int
forall a. a -> Max a
Max (Int -> Max Int) -> (Word32 -> Int) -> Word32 -> Max Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Max Int) -> Get Word32 -> Get (Max Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32be
    Min Int
minLines    <- Int -> Min Int
forall a. a -> Min a
Min (Int -> Min Int) -> (Word32 -> Int) -> Word32 -> Min Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Min Int) -> Get Word32 -> Get (Min Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32be
    Max Int
offsetAfter <- Int -> Max Int
forall a. a -> Max a
Max (Int -> Max Int) -> (Word32 -> Int) -> Word32 -> Max Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Max Int) -> Get Word32 -> Get (Max Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32be
    Int -> Get ()
skip Int
headerReservedLength
    
    Header -> Get Header
forall (m :: * -> *) a. Monad m => a -> m a
return Header :: FortuneStats -> Int -> Header
Header {stats :: FortuneStats
stats = FortuneStats :: Sum Int
-> Max Int
-> Min Int
-> Max Int
-> Min Int
-> Max Int
-> FortuneStats
FortuneStats{Min Int
Max Int
Sum Int
maxLines :: Max Int
minLines :: Min Int
maxChars :: Max Int
minChars :: Min Int
offsetAfter :: Max Int
numFortunes :: Sum Int
offsetAfter :: Max Int
minLines :: Min Int
maxLines :: Max Int
minChars :: Min Int
maxChars :: Max Int
numFortunes :: Sum Int
..}, Int
indexLoc :: Int
indexLoc :: Int
..}

putHeader :: Header -> PutM ()
putHeader Header {stats :: Header -> FortuneStats
stats = FortuneStats{Min Int
Max Int
Sum Int
maxLines :: Max Int
minLines :: Min Int
maxChars :: Max Int
minChars :: Min Int
offsetAfter :: Max Int
numFortunes :: Sum Int
maxLines :: FortuneStats -> Max Int
minLines :: FortuneStats -> Min Int
maxChars :: FortuneStats -> Max Int
minChars :: FortuneStats -> Min Int
offsetAfter :: FortuneStats -> Max Int
numFortunes :: FortuneStats -> Sum Int
..}, Int
indexLoc :: Int
indexLoc :: Header -> Int
..} = do
    Putter Word32
putWord32be Word32
magic
    Putter Word32
putWord32be Word32
currentVersion
    Putter Word32
putWord32be (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
indexLoc)
    Putter Word32
putWord32be (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Sum Int -> Int
forall a. Sum a -> a
getSum Sum Int
numFortunes))
    Putter Word32
putWord32be (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Max Int -> Int
forall a. Max a -> a
getMax Max Int
maxChars))
    Putter Word32
putWord32be (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Min Int -> Int
forall a. Min a -> a
getMin Min Int
minChars))
    Putter Word32
putWord32be (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Max Int -> Int
forall a. Max a -> a
getMax Max Int
maxLines))
    Putter Word32
putWord32be (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Min Int -> Int
forall a. Min a -> a
getMin Min Int
minLines))
    Putter Word32
putWord32be (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Max Int -> Int
forall a. Max a -> a
getMax Max Int
offsetAfter))
    Int -> PutM () -> PutM ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
headerReservedLength (Putter Word8
putWord8 Word8
0)

-- |A handle to an open fortune index file.
data Index = Index !Handle !(MVar Header)

-- |@openIndex path writeMode@: Opens the index file at @path@.  The 'Index' will
-- be writable if @writeMode@ is 'True'.  If there is no index file at that path, 
-- an error will be thrown or the index will be created, depending on @writeMode@.
openIndex :: FilePath -> Bool -> IO Index
openIndex :: String -> Bool -> IO Index
openIndex String
path Bool
writeMode = do
    Handle
file <- String -> IOMode -> IO Handle
openFile String
path (if Bool
writeMode then IOMode
ReadWriteMode else IOMode
ReadMode)
    Handle -> Bool -> IO Index
openIndex' Handle
file Bool
writeMode

-- |Create an in-memory index - useful for working with files when, for whatever reason,
-- you cannot create a valid index.
createVirtualIndex :: IO Index
createVirtualIndex :: IO Index
createVirtualIndex = do
    Knob
knob <- ByteString -> IO Knob
forall (m :: * -> *). MonadIO m => ByteString -> m Knob
newKnob ByteString
BS.empty
    Handle
file <- Knob -> String -> IOMode -> IO Handle
forall (m :: * -> *).
MonadIO m =>
Knob -> String -> IOMode -> m Handle
newFileHandle Knob
knob String
"<createVirtualIndex>" IOMode
ReadWriteMode
    Handle -> Bool -> IO Index
openIndex' Handle
file Bool
True

openIndex' :: Handle -> Bool -> IO Index
openIndex' :: Handle -> Bool -> IO Index
openIndex' Handle
file Bool
writeMode = do
    Handle -> Bool -> IO ()
hSetBinaryMode Handle
file Bool
True
    Handle -> BufferMode -> IO ()
hSetBuffering Handle
file BufferMode
NoBuffering
    
    Bool
isEmpty <- Handle -> IO Bool
hIsEOF Handle
file
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
writeMode Bool -> Bool -> Bool
&& Bool
isEmpty) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Handle -> ByteString -> IO ()
BS.hPut Handle
file (PutM () -> ByteString
runPut (Header -> PutM ()
putHeader Header
emptyHeader))
        Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
file SeekMode
AbsoluteSeek Integer
0
        
    ByteString
hdr <- Handle -> Int -> IO ByteString
BS.hGet Handle
file Int
headerLength 
    
    case Get Header -> ByteString -> Either String Header
forall a. Get a -> ByteString -> Either String a
runGet Get Header
getHeader ByteString
hdr of
        Left String
err -> String -> IO Index
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
        Right Header
hdr -> do
            -- check header for problems, fixing what we can and throwing what we can't
            Maybe IndexProblem
mbProblem <- Handle -> Header -> IO (Maybe IndexProblem)
checkIndex_ Handle
file Header
hdr
            case Maybe IndexProblem
mbProblem of
                Just (HeaderProblem StatsProblem{}) -> IO Header -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Handle -> Header -> IO Header
rebuildStats_ Handle
file Header
hdr)
                Just IndexProblem
p                              -> IndexProblem -> IO ()
forall e a. Exception e => e -> IO a
throwIO IndexProblem
p
                Maybe IndexProblem
Nothing                             -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            
            MVar Header
hdrRef <- Header -> IO (MVar Header)
forall a. a -> IO (MVar a)
newMVar Header
hdr
            Index -> IO Index
forall (m :: * -> *) a. Monad m => a -> m a
return (Handle -> MVar Header -> Index
Index Handle
file MVar Header
hdrRef)

-- |Close an index file.  Subsequent accesses will fail.
closeIndex :: Index -> IO ()
closeIndex :: Index -> IO ()
closeIndex (Index Handle
file MVar Header
mv) = do
    Handle -> IO ()
hClose Handle
file
    MVar Header -> IO Header
forall a. MVar a -> IO a
takeMVar MVar Header
mv
    MVar Header -> Header -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Header
mv (IndexProblem -> Header
forall a e. Exception e => e -> a
throw IndexProblem
AccessToClosedIndex)

-- |Errors that can be thrown indicating a problem with an index file.
data IndexProblem
    = HeaderProblem !HeaderProblem
    | TableLongerThanFile
    | AccessToClosedIndex
    deriving (IndexProblem -> IndexProblem -> Bool
(IndexProblem -> IndexProblem -> Bool)
-> (IndexProblem -> IndexProblem -> Bool) -> Eq IndexProblem
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IndexProblem -> IndexProblem -> Bool
$c/= :: IndexProblem -> IndexProblem -> Bool
== :: IndexProblem -> IndexProblem -> Bool
$c== :: IndexProblem -> IndexProblem -> Bool
Eq, Eq IndexProblem
Eq IndexProblem
-> (IndexProblem -> IndexProblem -> Ordering)
-> (IndexProblem -> IndexProblem -> Bool)
-> (IndexProblem -> IndexProblem -> Bool)
-> (IndexProblem -> IndexProblem -> Bool)
-> (IndexProblem -> IndexProblem -> Bool)
-> (IndexProblem -> IndexProblem -> IndexProblem)
-> (IndexProblem -> IndexProblem -> IndexProblem)
-> Ord IndexProblem
IndexProblem -> IndexProblem -> Bool
IndexProblem -> IndexProblem -> Ordering
IndexProblem -> IndexProblem -> IndexProblem
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: IndexProblem -> IndexProblem -> IndexProblem
$cmin :: IndexProblem -> IndexProblem -> IndexProblem
max :: IndexProblem -> IndexProblem -> IndexProblem
$cmax :: IndexProblem -> IndexProblem -> IndexProblem
>= :: IndexProblem -> IndexProblem -> Bool
$c>= :: IndexProblem -> IndexProblem -> Bool
> :: IndexProblem -> IndexProblem -> Bool
$c> :: IndexProblem -> IndexProblem -> Bool
<= :: IndexProblem -> IndexProblem -> Bool
$c<= :: IndexProblem -> IndexProblem -> Bool
< :: IndexProblem -> IndexProblem -> Bool
$c< :: IndexProblem -> IndexProblem -> Bool
compare :: IndexProblem -> IndexProblem -> Ordering
$ccompare :: IndexProblem -> IndexProblem -> Ordering
$cp1Ord :: Eq IndexProblem
Ord, ReadPrec [IndexProblem]
ReadPrec IndexProblem
Int -> ReadS IndexProblem
ReadS [IndexProblem]
(Int -> ReadS IndexProblem)
-> ReadS [IndexProblem]
-> ReadPrec IndexProblem
-> ReadPrec [IndexProblem]
-> Read IndexProblem
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [IndexProblem]
$creadListPrec :: ReadPrec [IndexProblem]
readPrec :: ReadPrec IndexProblem
$creadPrec :: ReadPrec IndexProblem
readList :: ReadS [IndexProblem]
$creadList :: ReadS [IndexProblem]
readsPrec :: Int -> ReadS IndexProblem
$creadsPrec :: Int -> ReadS IndexProblem
Read, Int -> IndexProblem -> ShowS
[IndexProblem] -> ShowS
IndexProblem -> String
(Int -> IndexProblem -> ShowS)
-> (IndexProblem -> String)
-> ([IndexProblem] -> ShowS)
-> Show IndexProblem
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IndexProblem] -> ShowS
$cshowList :: [IndexProblem] -> ShowS
show :: IndexProblem -> String
$cshow :: IndexProblem -> String
showsPrec :: Int -> IndexProblem -> ShowS
$cshowsPrec :: Int -> IndexProblem -> ShowS
Show, Typeable)

-- These instances allow any 'problem' to be caught as an instance of any other,
-- to the extent that that "makes sense"
instance Exception StatsProblem where
    fromException :: SomeException -> Maybe StatsProblem
fromException se :: SomeException
se@(SomeException e
e) = [StatsProblem] -> Maybe StatsProblem
forall a. [a] -> Maybe a
listToMaybe ([StatsProblem] -> Maybe StatsProblem)
-> [StatsProblem] -> Maybe StatsProblem
forall a b. (a -> b) -> a -> b
$ [Maybe StatsProblem] -> [StatsProblem]
forall a. [Maybe a] -> [a]
catMaybes
        [ e -> Maybe StatsProblem
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast e
e
        , do StatsProblem StatsProblem
p <- SomeException -> Maybe HeaderProblem
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se; StatsProblem -> Maybe StatsProblem
forall (m :: * -> *) a. Monad m => a -> m a
return StatsProblem
p
        ]
instance Exception HeaderProblem where
    fromException :: SomeException -> Maybe HeaderProblem
fromException se :: SomeException
se@(SomeException e
e) = [HeaderProblem] -> Maybe HeaderProblem
forall a. [a] -> Maybe a
listToMaybe ([HeaderProblem] -> Maybe HeaderProblem)
-> [HeaderProblem] -> Maybe HeaderProblem
forall a b. (a -> b) -> a -> b
$ [Maybe HeaderProblem] -> [HeaderProblem]
forall a. [Maybe a] -> [a]
catMaybes
        [ e -> Maybe HeaderProblem
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast e
e
        , StatsProblem -> HeaderProblem
StatsProblem (StatsProblem -> HeaderProblem)
-> Maybe StatsProblem -> Maybe HeaderProblem
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SomeException -> Maybe StatsProblem
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se
        , do HeaderProblem HeaderProblem
p <- SomeException -> Maybe IndexProblem
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se; HeaderProblem -> Maybe HeaderProblem
forall (m :: * -> *) a. Monad m => a -> m a
return HeaderProblem
p
        ]
instance Exception IndexProblem where
    fromException :: SomeException -> Maybe IndexProblem
fromException se :: SomeException
se@(SomeException e
e) = [IndexProblem] -> Maybe IndexProblem
forall a. [a] -> Maybe a
listToMaybe ([IndexProblem] -> Maybe IndexProblem)
-> [IndexProblem] -> Maybe IndexProblem
forall a b. (a -> b) -> a -> b
$ [Maybe IndexProblem] -> [IndexProblem]
forall a. [Maybe a] -> [a]
catMaybes
        [ e -> Maybe IndexProblem
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast e
e
        , HeaderProblem -> IndexProblem
HeaderProblem (HeaderProblem -> IndexProblem)
-> Maybe HeaderProblem -> Maybe IndexProblem
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SomeException -> Maybe HeaderProblem
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se
        ]

-- |Force a consistency check on an index file.
checkIndex :: Index -> IO (Maybe IndexProblem)
checkIndex :: Index -> IO (Maybe IndexProblem)
checkIndex (Index Handle
file MVar Header
hdrRef) =
    (IndexProblem -> Maybe IndexProblem)
-> (Maybe IndexProblem -> Maybe IndexProblem)
-> Either IndexProblem (Maybe IndexProblem)
-> Maybe IndexProblem
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either IndexProblem -> Maybe IndexProblem
forall a. a -> Maybe a
Just Maybe IndexProblem -> Maybe IndexProblem
forall a. a -> a
id (Either IndexProblem (Maybe IndexProblem) -> Maybe IndexProblem)
-> IO (Either IndexProblem (Maybe IndexProblem))
-> IO (Maybe IndexProblem)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe IndexProblem)
-> IO (Either IndexProblem (Maybe IndexProblem))
forall e a. Exception e => IO a -> IO (Either e a)
try (MVar Header
-> (Header -> IO (Maybe IndexProblem)) -> IO (Maybe IndexProblem)
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar Header
hdrRef (Handle -> Header -> IO (Maybe IndexProblem)
checkIndex_ Handle
file))

checkIndex_ :: Handle -> Header -> IO (Maybe IndexProblem)
checkIndex_ Handle
file Header
hdr =
    case Header -> Maybe HeaderProblem
checkHeader Header
hdr of
        Just HeaderProblem
problem -> Maybe IndexProblem -> IO (Maybe IndexProblem)
forall (m :: * -> *) a. Monad m => a -> m a
return (IndexProblem -> Maybe IndexProblem
forall a. a -> Maybe a
Just (HeaderProblem -> IndexProblem
HeaderProblem HeaderProblem
problem))
        Maybe HeaderProblem
Nothing -> do
            let base :: Int
base = Header -> Int
indexLoc Header
hdr
                count :: Sum Int
count = FortuneStats -> Sum Int
numFortunes (Header -> FortuneStats
stats Header
hdr)
                end :: Int
end = Int
base Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Sum Int -> Int
forall a. Sum a -> a
getSum Sum Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
indexEntryLength
            Integer
len <- Handle -> IO Integer
hFileSize Handle
file
            Maybe IndexProblem -> IO (Maybe IndexProblem)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe IndexProblem -> IO (Maybe IndexProblem))
-> Maybe IndexProblem -> IO (Maybe IndexProblem)
forall a b. (a -> b) -> a -> b
$! if Integer
len Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
end
                then IndexProblem -> Maybe IndexProblem
forall a. a -> Maybe a
Just IndexProblem
TableLongerThanFile
                else Maybe IndexProblem
forall a. Maybe a
Nothing

withIndex :: Index -> (Handle -> Int -> Int -> IO b) -> IO b
withIndex ix :: Index
ix@(Index Handle
file MVar Header
hdrRef) Handle -> Int -> Int -> IO b
action = MVar Header -> (Header -> IO b) -> IO b
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar Header
hdrRef ((Header -> IO b) -> IO b) -> (Header -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \Header
hdr -> do
    let base :: Int
base = Header -> Int
indexLoc Header
hdr
        count :: Sum Int
count = FortuneStats -> Sum Int
numFortunes (Header -> FortuneStats
stats Header
hdr) 
    b
res <- Handle -> Int -> Int -> IO b
action Handle
file Int
base (Sum Int -> Int
forall a. Sum a -> a
getSum Sum Int
count)
    
    Handle -> Header -> IO (Maybe IndexProblem)
checkIndex_ Handle
file Header
hdr IO (Maybe IndexProblem) -> (Maybe IndexProblem -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO b -> (IndexProblem -> IO b) -> Maybe IndexProblem -> IO b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
res) IndexProblem -> IO b
forall e a. Exception e => e -> IO a
throwIO
    

modifyHeader :: Index -> (Handle -> Header -> IO Header) -> IO ()
modifyHeader (Index Handle
file MVar Header
hdrRef) Handle -> Header -> IO Header
action = MVar Header -> (Header -> IO Header) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar Header
hdrRef ((Header -> IO Header) -> IO ()) -> (Header -> IO Header) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Header
hdr -> do
    Header
newHdr <- Handle -> Header -> IO Header
action Handle
file Header
hdr
    
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Header
newHdr Header -> Header -> Bool
forall a. Eq a => a -> a -> Bool
/= Header
hdr) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
file SeekMode
AbsoluteSeek Integer
0
        Handle -> ByteString -> IO ()
BS.hPut Handle
file (PutM () -> ByteString
runPut (Header -> PutM ()
putHeader Header
newHdr))
    
    Handle -> Header -> IO (Maybe IndexProblem)
checkIndex_ Handle
file Header
newHdr IO (Maybe IndexProblem)
-> (Maybe IndexProblem -> IO Header) -> IO Header
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO Header
-> (IndexProblem -> IO Header) -> Maybe IndexProblem -> IO Header
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Header -> IO Header
forall (m :: * -> *) a. Monad m => a -> m a
return Header
newHdr) IndexProblem -> IO Header
forall e a. Exception e => e -> IO a
throwIO

-- |Get some cached stats about the fortunes indexed in this file.
getStats :: Index -> IO FortuneStats
getStats :: Index -> IO FortuneStats
getStats (Index Handle
_ MVar Header
hdrRef) = Header -> FortuneStats
stats (Header -> FortuneStats) -> IO Header -> IO FortuneStats
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVar Header -> IO Header
forall a. MVar a -> IO a
readMVar MVar Header
hdrRef

indexEntryLength :: Int
indexEntryLength = Int
16 -- bytes

-- |Conceptually, an 'Index' file is just a header containing 'FortuneStats' and an array of these entries.
-- An 'IndexEntry' stores the information needed to locate one string in the fortune fiel, as well as some
-- basic stats about that one file (from which the 'FortuneStats' will be derived).
data IndexEntry = IndexEntry
    { IndexEntry -> Int
stringOffset  :: !Int
        -- ^ The location of the string in the file, as a byte offset
    , IndexEntry -> Int
stringBytes   :: !Int
        -- ^ The number of bytes the string occupies.
    , IndexEntry -> Int
stringChars   :: !Int
        -- ^ The number of characters in the string.
    , IndexEntry -> Int
stringLines   :: !Int
        -- ^ The number of lines in the string.
    } deriving (IndexEntry -> IndexEntry -> Bool
(IndexEntry -> IndexEntry -> Bool)
-> (IndexEntry -> IndexEntry -> Bool) -> Eq IndexEntry
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IndexEntry -> IndexEntry -> Bool
$c/= :: IndexEntry -> IndexEntry -> Bool
== :: IndexEntry -> IndexEntry -> Bool
$c== :: IndexEntry -> IndexEntry -> Bool
Eq, Eq IndexEntry
Eq IndexEntry
-> (IndexEntry -> IndexEntry -> Ordering)
-> (IndexEntry -> IndexEntry -> Bool)
-> (IndexEntry -> IndexEntry -> Bool)
-> (IndexEntry -> IndexEntry -> Bool)
-> (IndexEntry -> IndexEntry -> Bool)
-> (IndexEntry -> IndexEntry -> IndexEntry)
-> (IndexEntry -> IndexEntry -> IndexEntry)
-> Ord IndexEntry
IndexEntry -> IndexEntry -> Bool
IndexEntry -> IndexEntry -> Ordering
IndexEntry -> IndexEntry -> IndexEntry
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: IndexEntry -> IndexEntry -> IndexEntry
$cmin :: IndexEntry -> IndexEntry -> IndexEntry
max :: IndexEntry -> IndexEntry -> IndexEntry
$cmax :: IndexEntry -> IndexEntry -> IndexEntry
>= :: IndexEntry -> IndexEntry -> Bool
$c>= :: IndexEntry -> IndexEntry -> Bool
> :: IndexEntry -> IndexEntry -> Bool
$c> :: IndexEntry -> IndexEntry -> Bool
<= :: IndexEntry -> IndexEntry -> Bool
$c<= :: IndexEntry -> IndexEntry -> Bool
< :: IndexEntry -> IndexEntry -> Bool
$c< :: IndexEntry -> IndexEntry -> Bool
compare :: IndexEntry -> IndexEntry -> Ordering
$ccompare :: IndexEntry -> IndexEntry -> Ordering
$cp1Ord :: Eq IndexEntry
Ord, Int -> IndexEntry -> ShowS
[IndexEntry] -> ShowS
IndexEntry -> String
(Int -> IndexEntry -> ShowS)
-> (IndexEntry -> String)
-> ([IndexEntry] -> ShowS)
-> Show IndexEntry
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IndexEntry] -> ShowS
$cshowList :: [IndexEntry] -> ShowS
show :: IndexEntry -> String
$cshow :: IndexEntry -> String
showsPrec :: Int -> IndexEntry -> ShowS
$cshowsPrec :: Int -> IndexEntry -> ShowS
Show)

-- |Convert one index entry to a 'FortuneStats' record describing it.
indexEntryStats :: IndexEntry -> FortuneStats
indexEntryStats :: IndexEntry -> FortuneStats
indexEntryStats (IndexEntry Int
o Int
n Int
cs Int
ls) = FortuneStats :: Sum Int
-> Max Int
-> Min Int
-> Max Int
-> Min Int
-> Max Int
-> FortuneStats
FortuneStats
    { numFortunes :: Sum Int
numFortunes = Int -> Sum Int
forall a. a -> Sum a
Sum Int
1, offsetAfter :: Max Int
offsetAfter = Int -> Max Int
forall a. a -> Max a
Max (Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n)
    , minChars :: Min Int
minChars    = Int -> Min Int
forall a. a -> Min a
Min Int
cs, maxChars :: Max Int
maxChars    = Int -> Max Int
forall a. a -> Max a
Max Int
cs
    , minLines :: Min Int
minLines    = Int -> Min Int
forall a. a -> Min a
Min Int
ls, maxLines :: Max Int
maxLines    = Int -> Max Int
forall a. a -> Max a
Max Int
ls
    }

putIndexEntry :: IndexEntry -> PutM ()
putIndexEntry IndexEntry{Int
stringLines :: Int
stringChars :: Int
stringBytes :: Int
stringOffset :: Int
stringLines :: IndexEntry -> Int
stringChars :: IndexEntry -> Int
stringBytes :: IndexEntry -> Int
stringOffset :: IndexEntry -> Int
..} = do
    Putter Word32
putWord32be (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
stringOffset)
    Putter Word32
putWord32be (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
stringBytes)
    Putter Word32
putWord32be (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
stringChars)
    Putter Word32
putWord32be (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
stringLines)

getIndexEntry :: Get IndexEntry
getIndexEntry = do
    Int
stringOffset <- Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Get Word32 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32be
    Int
stringBytes  <- Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Get Word32 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32be
    Int
stringChars  <- Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Get Word32 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32be
    Int
stringLines  <- Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Get Word32 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32be
    IndexEntry -> Get IndexEntry
forall (m :: * -> *) a. Monad m => a -> m a
return IndexEntry :: Int -> Int -> Int -> Int -> IndexEntry
IndexEntry{Int
stringLines :: Int
stringChars :: Int
stringBytes :: Int
stringOffset :: Int
stringLines :: Int
stringChars :: Int
stringBytes :: Int
stringOffset :: Int
..}

-- |Read all the entries in an 'Index'
getEntries :: Index -> IO (V.Vector IndexEntry)
getEntries :: Index -> IO (Vector IndexEntry)
getEntries Index
ix = Index
-> (Handle -> Int -> Int -> IO (Vector IndexEntry))
-> IO (Vector IndexEntry)
forall b. Index -> (Handle -> Int -> Int -> IO b) -> IO b
withIndex Index
ix ((Handle -> Int -> Int -> IO (Vector IndexEntry))
 -> IO (Vector IndexEntry))
-> (Handle -> Int -> Int -> IO (Vector IndexEntry))
-> IO (Vector IndexEntry)
forall a b. (a -> b) -> a -> b
$ \Handle
file Int
base Int
count -> do
    Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
file SeekMode
AbsoluteSeek (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
base)
    ByteString
buf <- Handle -> Int -> IO ByteString
BS.hGet Handle
file (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
indexEntryLength)
    Get (Vector IndexEntry) -> ByteString -> IO (Vector IndexEntry)
forall (m :: * -> *) a. MonadFail m => Get a -> ByteString -> m a
runGetM (Int -> Get IndexEntry -> Get (Vector IndexEntry)
forall (m :: * -> *) a. Monad m => Int -> m a -> m (Vector a)
V.replicateM Int
count Get IndexEntry
getIndexEntry) ByteString
buf

-- |Read a specified entry from an 'Index'.
getEntry :: Index -> Int -> IO IndexEntry
getEntry :: Index -> Int -> IO IndexEntry
getEntry ix :: Index
ix@(Index Handle
file MVar Header
hdrRef) Int
i
    | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0     = IO IndexEntry
forall a. IO a
rangeErr
    | Bool
otherwise = Index -> (Handle -> Int -> Int -> IO IndexEntry) -> IO IndexEntry
forall b. Index -> (Handle -> Int -> Int -> IO b) -> IO b
withIndex Index
ix ((Handle -> Int -> Int -> IO IndexEntry) -> IO IndexEntry)
-> (Handle -> Int -> Int -> IO IndexEntry) -> IO IndexEntry
forall a b. (a -> b) -> a -> b
$ \Handle
file Int
base Int
count -> do
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
count) IO ()
forall a. IO a
rangeErr
        
        Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
file SeekMode
AbsoluteSeek (Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int
base Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
indexEntryLength))
        Handle -> Int -> IO ByteString
BS.hGet Handle
file Int
indexEntryLength IO ByteString -> (ByteString -> IO IndexEntry) -> IO IndexEntry
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Get IndexEntry -> ByteString -> IO IndexEntry
forall (m :: * -> *) a. MonadFail m => Get a -> ByteString -> m a
runGetM Get IndexEntry
getIndexEntry
    where rangeErr :: IO a
rangeErr = String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"getEntry: index out of range: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i)

-- |Repeatedly invoke a generator for index entries until it returns 'Nothing',
-- appending all entries returned to the index file.
unfoldEntries :: Index -> IO (Maybe IndexEntry) -> IO ()
unfoldEntries :: Index -> IO (Maybe IndexEntry) -> IO ()
unfoldEntries Index
ix IO (Maybe IndexEntry)
getEntry = Index -> (Handle -> Header -> IO Header) -> IO ()
modifyHeader Index
ix ((Handle -> Header -> IO Header) -> IO ())
-> (Handle -> Header -> IO Header) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
file Header
hdr -> do
        let base :: Int
base = Header -> Int
indexLoc Header
hdr
            count :: Sum Int
count = FortuneStats -> Sum Int
numFortunes (Header -> FortuneStats
stats Header
hdr)
            end :: Int
end = Int
base Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Sum Int -> Int
forall a. Sum a -> a
getSum Sum Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
indexEntryLength
            
            loop :: FortuneStats -> IO FortuneStats
loop FortuneStats
s = do
                Maybe IndexEntry
mbEntry <- IO (Maybe IndexEntry)
getEntry
                case Maybe IndexEntry
mbEntry of
                    Maybe IndexEntry
Nothing -> FortuneStats -> IO FortuneStats
forall (m :: * -> *) a. Monad m => a -> m a
return FortuneStats
s
                    Just IndexEntry
entry -> do
                        Handle -> ByteString -> IO ()
BS.hPut Handle
file (PutM () -> ByteString
runPut (IndexEntry -> PutM ()
putIndexEntry IndexEntry
entry))
                        FortuneStats -> IO FortuneStats
loop (FortuneStats -> IO FortuneStats)
-> FortuneStats -> IO FortuneStats
forall a b. (a -> b) -> a -> b
$! (FortuneStats
s FortuneStats -> FortuneStats -> FortuneStats
forall a. Semigroup a => a -> a -> a
<> IndexEntry -> FortuneStats
indexEntryStats IndexEntry
entry)
        
        Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
file SeekMode
AbsoluteSeek (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
end)
        FortuneStats
newStats <- FortuneStats -> IO FortuneStats
loop (Header -> FortuneStats
stats Header
hdr)
        
        Header -> IO Header
forall (m :: * -> *) a. Monad m => a -> m a
return Header
hdr {stats :: FortuneStats
stats = FortuneStats
newStats}

-- |Append all the given entries to the 'Index' file.
appendEntries :: Index -> V.Vector IndexEntry -> IO ()
appendEntries :: Index -> Vector IndexEntry -> IO ()
appendEntries Index
ix Vector IndexEntry
entries
    | Vector IndexEntry -> Bool
forall a. Vector a -> Bool
V.null Vector IndexEntry
entries    = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    | Bool
otherwise         = Index -> (Handle -> Header -> IO Header) -> IO ()
modifyHeader Index
ix ((Handle -> Header -> IO Header) -> IO ())
-> (Handle -> Header -> IO Header) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
file Header
hdr -> do
        let base :: Int
base = Header -> Int
indexLoc Header
hdr
            count :: Sum Int
count = FortuneStats -> Sum Int
numFortunes (Header -> FortuneStats
stats Header
hdr)
            end :: Int
end = Int
base Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Sum Int -> Int
forall a. Sum a -> a
getSum Sum Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
indexEntryLength
        
        Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
file SeekMode
AbsoluteSeek (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
end)
        Handle -> ByteString -> IO ()
BS.hPut Handle
file (PutM () -> ByteString
runPut ((IndexEntry -> PutM ()) -> Vector IndexEntry -> PutM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> Vector a -> m ()
V.mapM_ IndexEntry -> PutM ()
putIndexEntry Vector IndexEntry
entries))
        
        Header -> IO Header
forall (m :: * -> *) a. Monad m => a -> m a
return Header
hdr {stats :: FortuneStats
stats = Header -> FortuneStats
stats Header
hdr FortuneStats -> FortuneStats -> FortuneStats
forall a. Semigroup a => a -> a -> a
<> (IndexEntry -> FortuneStats) -> Vector IndexEntry -> FortuneStats
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap IndexEntry -> FortuneStats
indexEntryStats Vector IndexEntry
entries}

-- |Append a single 'IndexEntry' to an 'Index' file.
appendEntry :: Index -> IndexEntry -> IO ()
appendEntry :: Index -> IndexEntry -> IO ()
appendEntry Index
ix = Index -> Vector IndexEntry -> IO ()
appendEntries Index
ix (Vector IndexEntry -> IO ())
-> (IndexEntry -> Vector IndexEntry) -> IndexEntry -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IndexEntry -> Vector IndexEntry
forall a. a -> Vector a
V.singleton

-- |Delete all entries from an 'Index'.
clearIndex :: Index -> IO ()
clearIndex :: Index -> IO ()
clearIndex Index
ix = Index -> (Handle -> Header -> IO Header) -> IO ()
modifyHeader Index
ix ((Handle -> Header -> IO Header) -> IO ())
-> (Handle -> Header -> IO Header) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
file Header
_ -> do
    Handle -> Integer -> IO ()
hSetFileSize Handle
file (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
headerLength)
    Header -> IO Header
forall (m :: * -> *) a. Monad m => a -> m a
return Header
emptyHeader

-- |All the operations here should preserve correctness of stats, but just in case...
-- This procedure forces the stats to be recomputed.
rebuildStats :: Index -> IO ()
rebuildStats :: Index -> IO ()
rebuildStats Index
ix = Index -> (Handle -> Header -> IO Header) -> IO ()
modifyHeader Index
ix Handle -> Header -> IO Header
rebuildStats_

rebuildStats_ :: Handle -> Header -> IO Header
rebuildStats_ Handle
file Header
hdr = do
    let n :: Int
n = Sum Int -> Int
forall a. Sum a -> a
getSum (FortuneStats -> Sum Int
numFortunes (Header -> FortuneStats
stats Header
hdr))
        chunk :: Int
chunk = Int
4096 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
indexEntryLength
        loop :: Int -> FortuneStats -> IO FortuneStats
loop Int
i FortuneStats
s
            | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n    = FortuneStats -> IO FortuneStats
forall (m :: * -> *) a. Monad m => a -> m a
return FortuneStats
s
            | Bool
otherwise = do
                let m :: Int
m = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
chunk (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)
                [IndexEntry]
entries <- Get [IndexEntry] -> ByteString -> IO [IndexEntry]
forall (m :: * -> *) a. MonadFail m => Get a -> ByteString -> m a
runGetM (Int -> Get IndexEntry -> Get [IndexEntry]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
m Get IndexEntry
getIndexEntry) (ByteString -> IO [IndexEntry]) -> IO ByteString -> IO [IndexEntry]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Handle -> Int -> IO ByteString
BS.hGet Handle
file (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
indexEntryLength)
                Int -> FortuneStats -> IO FortuneStats
loop (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
chunk) (FortuneStats
s FortuneStats -> FortuneStats -> FortuneStats
forall a. Semigroup a => a -> a -> a
<> (IndexEntry -> FortuneStats) -> [IndexEntry] -> FortuneStats
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap IndexEntry -> FortuneStats
indexEntryStats [IndexEntry]
entries)
    
    Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
file SeekMode
AbsoluteSeek (Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Header -> Int
indexLoc Header
hdr))
    FortuneStats
newStats <- Int -> FortuneStats -> IO FortuneStats
loop Int
0 FortuneStats
forall a. Monoid a => a
mempty
    
    Header -> IO Header
forall (m :: * -> *) a. Monad m => a -> m a
return Header
hdr {stats :: FortuneStats
stats = FortuneStats
newStats}