{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE RecordWildCards #-}
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.Applicative
import Control.Concurrent.MVar
import Control.Exception
import Control.Monad
import qualified Data.ByteString as BS
import Data.Foldable (foldMap)
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 getThing :: 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 = 0xbdcbcdb
currentVersion :: Word32
currentVersion = 2
= 64
= 28
data =
{ 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)
= FortuneStats -> Int -> Header
Header FortuneStats
forall a. Monoid a => a
mempty Int
headerLength
data
= BadMagicNumber !Word32
| UnsupportedVersion !Word32
| StatsProblem !StatsProblem
|
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)
(Header stats :: FortuneStats
stats loc :: 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)]
= 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 getRest :: Get Header
getRest -> Get Header
getRest
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 $WHeader :: FortuneStats -> Int -> Header
Header {stats :: FortuneStats
stats = $WFortuneStats :: Sum Int
-> Max Int
-> Min Int
-> Max Int
-> Min Int
-> Max Int
-> FortuneStats
FortuneStats{..}, ..}
Header {stats :: Header -> FortuneStats
stats = FortuneStats{..}, ..} = 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 0)
data Index = Index !Handle !(MVar Header)
openIndex :: FilePath -> Bool -> IO Index
openIndex :: String -> Bool -> IO Index
openIndex path :: String
path writeMode :: 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
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 "<createVirtualIndex>" IOMode
ReadWriteMode
Handle -> Bool -> IO Index
openIndex' Handle
file Bool
True
openIndex' :: Handle -> Bool -> IO Index
openIndex' :: Handle -> Bool -> IO Index
openIndex' file :: Handle
file writeMode :: 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 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 err :: String
err -> String -> IO Index
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
Right hdr :: Header
hdr -> do
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 p :: IndexProblem
p -> IndexProblem -> IO ()
forall e a. Exception e => e -> IO a
throwIO IndexProblem
p
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)
closeIndex :: Index -> IO ()
closeIndex :: Index -> IO ()
closeIndex (Index file :: Handle
file mv :: 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)
data IndexProblem
= !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)
instance Exception StatsProblem where
fromException :: SomeException -> Maybe StatsProblem
fromException se :: SomeException
se@(SomeException e :: 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 p :: 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
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 p :: 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
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
]
checkIndex :: Index -> IO (Maybe IndexProblem)
checkIndex :: Index -> IO (Maybe IndexProblem)
checkIndex (Index file :: Handle
file hdrRef :: 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_ file :: Handle
file hdr :: Header
hdr =
case Header -> Maybe HeaderProblem
checkHeader Header
hdr of
Just problem :: 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))
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 file :: Handle
file hdrRef :: MVar Header
hdrRef) action :: 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
$ \hdr :: 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
(Index file :: Handle
file hdrRef :: MVar Header
hdrRef) action :: 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
$ \hdr :: 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 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
getStats :: Index -> IO FortuneStats
getStats :: Index -> IO FortuneStats
getStats (Index _ hdrRef :: 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 = 16
data IndexEntry = IndexEntry
{ IndexEntry -> Int
stringOffset :: !Int
, IndexEntry -> Int
stringBytes :: !Int
, IndexEntry -> Int
stringChars :: !Int
, IndexEntry -> Int
stringLines :: !Int
} 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)
indexEntryStats :: IndexEntry -> FortuneStats
indexEntryStats :: IndexEntry -> FortuneStats
indexEntryStats (IndexEntry o :: Int
o n :: Int
n cs :: Int
cs ls :: Int
ls) = $WFortuneStats :: 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 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{..} = 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 $WIndexEntry :: Int -> Int -> Int -> Int -> IndexEntry
IndexEntry{..}
getEntries :: Index -> IO (V.Vector IndexEntry)
getEntries :: Index -> IO (Vector IndexEntry)
getEntries ix :: 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
$ \file :: Handle
file base :: Int
base count :: 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
getEntry :: Index -> Int -> IO IndexEntry
getEntry :: Index -> Int -> IO IndexEntry
getEntry ix :: Index
ix@(Index file :: Handle
file hdrRef :: MVar Header
hdrRef) i :: Int
i
| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 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
$ \file :: Handle
file base :: Int
base count :: 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 ("getEntry: index out of range: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i)
unfoldEntries :: Index -> IO (Maybe IndexEntry) -> IO ()
unfoldEntries :: Index -> IO (Maybe IndexEntry) -> IO ()
unfoldEntries ix :: Index
ix getEntry :: 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
$ \file :: Handle
file hdr :: 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 s :: FortuneStats
s = do
Maybe IndexEntry
mbEntry <- IO (Maybe IndexEntry)
getEntry
case Maybe IndexEntry
mbEntry of
Nothing -> FortuneStats -> IO FortuneStats
forall (m :: * -> *) a. Monad m => a -> m a
return FortuneStats
s
Just entry :: 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}
appendEntries :: Index -> V.Vector IndexEntry -> IO ()
appendEntries :: Index -> Vector IndexEntry -> IO ()
appendEntries ix :: Index
ix entries :: 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
$ \file :: Handle
file hdr :: 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}
appendEntry :: Index -> IndexEntry -> IO ()
appendEntry :: Index -> IndexEntry -> IO ()
appendEntry ix :: 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
clearIndex :: Index -> IO ()
clearIndex :: Index -> IO ()
clearIndex ix :: 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
$ \file :: Handle
file _ -> 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
rebuildStats :: Index -> IO ()
rebuildStats :: Index -> IO ()
rebuildStats ix :: Index
ix = Index -> (Handle -> Header -> IO Header) -> IO ()
modifyHeader Index
ix Handle -> Header -> IO Header
rebuildStats_
rebuildStats_ :: Handle -> Header -> IO Header
rebuildStats_ file :: Handle
file hdr :: 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 = 4096 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
indexEntryLength
loop :: Int -> FortuneStats -> IO FortuneStats
loop i :: Int
i s :: 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 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}