{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
module Data.Fortune.FortuneFile
     ( FortuneFile
     , fortuneFilePath
     , fortuneIndexPath
     , openFortuneFile
     , closeFortuneFile
     , getIndex
     , rebuildIndex
     , getFortune
     , getFortunes
     , getNumFortunes
     , appendFortune
     ) where

import Control.Applicative
import Control.Concurrent
import Control.Exception
import Control.Monad
import qualified Data.ByteString as BS
import qualified Data.ByteString.UTF8 as U
import Data.Fortune.Index
import Data.Fortune.Stats
import Data.IORef
import Data.Semigroup
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Encoding.Error as T
import qualified Data.Text.IO as T
import System.Directory
import System.FilePath
import System.IO

-- |A handle to an open fortune database.
data FortuneFile = FortuneFile 
    { FortuneFile -> FilePath
fortunePath       :: !FilePath
    , FortuneFile -> Char
fortuneDelim      :: !Char
    , FortuneFile -> Bool
fortuneWritable   :: !Bool
    , FortuneFile -> MVar (Maybe Handle)
fortuneFile       :: !(MVar (Maybe Handle))
    , FortuneFile -> MVar (Maybe Index)
fortuneIndex      :: !(MVar (Maybe Index))
    }

-- |Get the path of the text part of an open fortune database.
fortuneFilePath :: FortuneFile -> FilePath
fortuneFilePath :: FortuneFile -> FilePath
fortuneFilePath = FortuneFile -> FilePath
fortunePath

-- |Get the path of the index part of an open fortune database.
fortuneIndexPath :: FortuneFile -> FilePath
fortuneIndexPath :: FortuneFile -> FilePath
fortuneIndexPath f :: FortuneFile
f = FortuneFile -> FilePath
fortunePath FortuneFile
f FilePath -> FilePath -> FilePath
<.> "ix"

-- |@openFortuneFile path delim writeMode@: Open a fortune file at @path@,
-- using @delim@ as the character between strings, allowing writing if
-- @writeMode@ is set.  If no file exists at the specified path, an error
-- will be thrown or the file will be created, depending on @writeMode@.
openFortuneFile :: Char -> Bool -> FilePath -> IO FortuneFile
openFortuneFile :: Char -> Bool -> FilePath -> IO FortuneFile
openFortuneFile fortuneDelim :: Char
fortuneDelim fortuneWritable :: Bool
fortuneWritable fortunePath :: FilePath
fortunePath = do
    Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
fortunePath
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool
exists Bool -> Bool -> Bool
|| Bool
fortuneWritable))
        (FilePath -> IO ()
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail ("openFortuneFile: file does not exist: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
fortunePath))
    
    MVar (Maybe Handle)
fortuneFile  <- Maybe Handle -> IO (MVar (Maybe Handle))
forall a. a -> IO (MVar a)
newMVar Maybe Handle
forall a. Maybe a
Nothing
    MVar (Maybe Index)
fortuneIndex <- Maybe Index -> IO (MVar (Maybe Index))
forall a. a -> IO (MVar a)
newMVar Maybe Index
forall a. Maybe a
Nothing
    FortuneFile -> IO FortuneFile
forall (m :: * -> *) a. Monad m => a -> m a
return $WFortuneFile :: FilePath
-> Char
-> Bool
-> MVar (Maybe Handle)
-> MVar (Maybe Index)
-> FortuneFile
FortuneFile{..}

-- |Close a fortune file. Subsequent accesses will fail.
closeFortuneFile :: FortuneFile -> IO ()
closeFortuneFile :: FortuneFile -> IO ()
closeFortuneFile f :: FortuneFile
f = do
    IO () -> (Handle -> IO ()) -> Maybe Handle -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Handle -> IO ()
hClose     (Maybe Handle -> IO ()) -> IO (Maybe Handle) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MVar (Maybe Handle) -> IO (Maybe Handle)
forall a. MVar a -> IO a
takeMVar (FortuneFile -> MVar (Maybe Handle)
fortuneFile  FortuneFile
f)
    MVar (Maybe Handle) -> Maybe Handle -> IO ()
forall a. MVar a -> a -> IO ()
putMVar (FortuneFile -> MVar (Maybe Handle)
fortuneFile FortuneFile
f) (FilePath -> Maybe Handle
forall a. HasCallStack => FilePath -> a
error "Fortune file is closed")
    
    IO () -> (Index -> IO ()) -> Maybe Index -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Index -> IO ()
closeIndex (Maybe Index -> IO ()) -> IO (Maybe Index) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MVar (Maybe Index) -> IO (Maybe Index)
forall a. MVar a -> IO a
takeMVar (FortuneFile -> MVar (Maybe Index)
fortuneIndex FortuneFile
f)
    MVar (Maybe Index) -> Maybe Index -> IO ()
forall a. MVar a -> a -> IO ()
putMVar (FortuneFile -> MVar (Maybe Index)
fortuneIndex FortuneFile
f) (FilePath -> Maybe Index
forall a. HasCallStack => FilePath -> a
error "Fortune file is closed")

withFortuneFile :: FortuneFile -> (Handle -> IO b) -> IO b
withFortuneFile f :: FortuneFile
f action :: Handle -> IO b
action = MVar (Maybe Handle)
-> (Maybe Handle -> IO (Maybe Handle, b)) -> IO b
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar (FortuneFile -> MVar (Maybe Handle)
fortuneFile FortuneFile
f) ((Maybe Handle -> IO (Maybe Handle, b)) -> IO b)
-> (Maybe Handle -> IO (Maybe Handle, b)) -> IO b
forall a b. (a -> b) -> a -> b
$ \mbFile :: Maybe Handle
mbFile ->
    case Maybe Handle
mbFile of
        Nothing -> do
            Handle
file <- FilePath -> IOMode -> IO Handle
openFile (FortuneFile -> FilePath
fortunePath FortuneFile
f) (if FortuneFile -> Bool
fortuneWritable FortuneFile
f then IOMode
ReadWriteMode else IOMode
ReadMode)
            b
res <- Handle -> IO b
action Handle
file
            (Maybe Handle, b) -> IO (Maybe Handle, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
file, b
res)
        Just file :: Handle
file -> do
            b
res <- Handle -> IO b
action Handle
file
            (Maybe Handle, b) -> IO (Maybe Handle, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
file, b
res)

withIndex :: FortuneFile -> (Index -> IO b) -> IO b
withIndex f :: FortuneFile
f action :: Index -> IO b
action =
    MVar (Maybe Index) -> (Maybe Index -> IO (Maybe Index, b)) -> IO b
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar (FortuneFile -> MVar (Maybe Index)
fortuneIndex FortuneFile
f) ((Maybe Index -> IO (Maybe Index, b)) -> IO b)
-> (Maybe Index -> IO (Maybe Index, b)) -> IO b
forall a b. (a -> b) -> a -> b
$ \mbIx :: Maybe Index
mbIx ->
        case Maybe Index
mbIx of
            Nothing -> do
                let path :: FilePath
path      = FortuneFile -> FilePath
fortuneIndexPath FortuneFile
f
                    writeMode :: Bool
writeMode = FortuneFile -> Bool
fortuneWritable  FortuneFile
f
                    -- if read-only, create an in-memory index if the real one exists but can't be opened
                    -- (Don't do that for read-write mode, because the writes would silently be dropped)
                    -- If building the in-memory one fails, re-throw the original exception; it's more
                    -- informative because it tells why the index couldn't be opened in the first place.
                    onExc :: SomeException -> IO Index
onExc e :: SomeException
e = if Bool
writeMode
                        then SomeException -> IO Index
forall e a. Exception e => e -> IO a
throwIO (SomeException
e :: SomeException)
                        else (SomeException -> IO Index) -> IO Index -> IO Index
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (SomeException -> SomeException -> IO Index
forall e a. Exception e => e -> e -> IO a
rethrow SomeException
e) (IO Index -> IO Index) -> IO Index -> IO Index
forall a b. (a -> b) -> a -> b
$ do
                            Index
ix <- IO Index
createVirtualIndex
                            FortuneFile -> (Handle -> IO ()) -> IO ()
forall b. FortuneFile -> (Handle -> IO b) -> IO b
withFortuneFile FortuneFile
f (\file :: Handle
file -> Char -> Handle -> Index -> IO ()
rebuildIndex' (FortuneFile -> Char
fortuneDelim FortuneFile
f) Handle
file Index
ix)
                            Index -> IO Index
forall (m :: * -> *) a. Monad m => a -> m a
return Index
ix
                    rethrow :: e -> e -> IO a
rethrow e :: e
e other :: e
other = e -> IO a
forall e a. Exception e => e -> IO a
throwIO (e
e e -> e -> e
forall a. a -> a -> a
`asTypeOf` e
other)
                
                Index
ix <- (SomeException -> IO Index) -> IO Index -> IO Index
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle SomeException -> IO Index
onExc (FilePath -> Bool -> IO Index
openIndex FilePath
path Bool
writeMode)
                b
res <- Index -> IO b
action Index
ix
                (Maybe Index, b) -> IO (Maybe Index, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Index -> Maybe Index
forall a. a -> Maybe a
Just Index
ix, b
res)
            Just ix :: Index
ix -> do
                b
res <- Index -> IO b
action Index
ix
                (Maybe Index, b) -> IO (Maybe Index, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Index -> Maybe Index
forall a. a -> Maybe a
Just Index
ix, b
res)


withFileAndIndex :: FortuneFile -> (Handle -> Index -> IO b) -> IO b
withFileAndIndex f :: FortuneFile
f action :: Handle -> Index -> IO b
action = FortuneFile -> (Handle -> IO b) -> IO b
forall b. FortuneFile -> (Handle -> IO b) -> IO b
withFortuneFile FortuneFile
f (FortuneFile -> (Index -> IO b) -> IO b
forall b. FortuneFile -> (Index -> IO b) -> IO b
withIndex FortuneFile
f ((Index -> IO b) -> IO b)
-> (Handle -> Index -> IO b) -> Handle -> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> Index -> IO b
action)

-- |Get the 'Index' of a 'FortuneFile', opening it if necessary.
getIndex :: FortuneFile -> IO Index
getIndex :: FortuneFile -> IO Index
getIndex fortunes :: FortuneFile
fortunes = FortuneFile -> (Index -> IO Index) -> IO Index
forall b. FortuneFile -> (Index -> IO b) -> IO b
withIndex FortuneFile
fortunes Index -> IO Index
forall (m :: * -> *) a. Monad m => a -> m a
return

-- |Clear a 'FortuneFile's 'Index' and rebuild it from the contents 
-- of the text file.
rebuildIndex :: FortuneFile -> IO ()
rebuildIndex :: FortuneFile -> IO ()
rebuildIndex f :: FortuneFile
f = FortuneFile -> (Handle -> Index -> IO ()) -> IO ()
forall b. FortuneFile -> (Handle -> Index -> IO b) -> IO b
withFileAndIndex FortuneFile
f (Char -> Handle -> Index -> IO ()
rebuildIndex' (FortuneFile -> Char
fortuneDelim FortuneFile
f))

rebuildIndex' :: Char -> Handle -> Index -> IO ()
rebuildIndex' delim :: Char
delim file :: Handle
file ix :: Index
ix = do
    Index -> IO ()
clearIndex Index
ix
    Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
file SeekMode
AbsoluteSeek 0
    
    IO (Maybe IndexEntry)
getEntry <- Handle -> Char -> IO (IO (Maybe IndexEntry))
enumFortuneLocs Handle
file Char
delim
    Index -> IO (Maybe IndexEntry) -> IO ()
unfoldEntries Index
ix IO (Maybe IndexEntry)
getEntry

-- |scan an open handle for UTF8 chars.  For each one found, returns the byte
-- location, the char, and the byte width of the char.
-- WARNING: seeks through file.  Do not perform any other IO on the same file until the returned thingy says "Nothing".
enumUTF8 :: Handle -> IO (IO (Maybe (Int, Char, Int)))
enumUTF8 :: Handle -> IO (IO (Maybe (Int, Char, Int)))
enumUTF8 file :: Handle
file = do
    let getChunk :: IO ByteString
getChunk = Handle -> Int -> IO ByteString
BS.hGet Handle
file 4096
        refill :: ByteString -> IO ByteString
refill buf :: ByteString
buf
            | ByteString -> Bool
BS.null ByteString
buf   = IO ByteString
getChunk
            | Bool
otherwise     = ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
buf
    
    IORef Int
bytePosRef <- Handle -> IO Integer
hTell Handle
file IO Integer -> (Integer -> IO (IORef Int)) -> IO (IORef Int)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (Int -> IO (IORef Int))
-> (Integer -> Int) -> Integer -> IO (IORef Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Int
forall a. Num a => Integer -> a
fromInteger
    IORef ByteString
bufRef     <- IO ByteString
getChunk IO ByteString
-> (ByteString -> IO (IORef ByteString)) -> IO (IORef ByteString)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> IO (IORef ByteString)
forall a. a -> IO (IORef a)
newIORef 
    
    let getOne :: IO (Maybe (Int, Char, Int))
getOne = do
            ByteString
buf <- IORef ByteString -> IO ByteString
forall a. IORef a -> IO a
readIORef IORef ByteString
bufRef
            if ByteString -> Bool
BS.null ByteString
buf
                then Maybe (Int, Char, Int) -> IO (Maybe (Int, Char, Int))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Int, Char, Int)
forall a. Maybe a
Nothing
                else case ByteString -> Maybe (Char, Int, ByteString)
tryDecode ByteString
buf of
                    Nothing -> do
                        -- this case occurs when there is a partial char at the
                        -- end of the buffer; check for more input; if there is none,
                        -- discard the partial char.
                        ByteString
more <- IO ByteString
getChunk
                        IORef ByteString -> ByteString -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef ByteString
bufRef (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$! if ByteString -> Bool
BS.null ByteString
more
                            then ByteString
BS.empty
                            else ByteString -> ByteString -> ByteString
BS.append ByteString
buf ByteString
more
                        IO (Maybe (Int, Char, Int))
getOne
                    Just (c :: Char
c, n :: Int
n, rest :: ByteString
rest) -> do
                        ByteString -> IO ByteString
refill ByteString
rest IO ByteString -> (ByteString -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IORef ByteString -> ByteString -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef ByteString
bufRef
                        Int
bytePos <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
bytePosRef
                        IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Int
bytePosRef (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$! Int
bytePos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n
                        
                        Maybe (Int, Char, Int) -> IO (Maybe (Int, Char, Int))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Int, Char, Int) -> Maybe (Int, Char, Int)
forall a. a -> Maybe a
Just (Int
bytePos, Char
c, Int
n))
    
    IO (Maybe (Int, Char, Int)) -> IO (IO (Maybe (Int, Char, Int)))
forall (m :: * -> *) a. Monad m => a -> m a
return IO (Maybe (Int, Char, Int))
getOne

-- try to decode the first UTF-8 char in a buffer.  If the decoding fails 
-- (returns replacement_char), then check if the whole buffer was used.
-- if it was, we probably just need more data so return Nothing.
tryDecode :: ByteString -> Maybe (Char, Int, ByteString)
tryDecode bs :: ByteString
bs = case ByteString -> Maybe (Char, Int)
U.decode ByteString
bs of
    Just (c :: Char
c, n :: Int
n)
        | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
U.replacement_char Bool -> Bool -> Bool
|| Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString -> Int
BS.length ByteString
bs
            -> (Char, Int, ByteString) -> Maybe (Char, Int, ByteString)
forall a. a -> Maybe a
Just (Char
c, Int
n, Int -> ByteString -> ByteString
BS.drop Int
n ByteString
bs)
    _       -> Maybe (Char, Int, ByteString)
forall a. Maybe a
Nothing

-- WARNING: seeks through file.  Do not perform any other IO on the same file until the returned thingy says "Nothing".
enumFortuneLocs :: Handle -> Char -> IO (IO (Maybe IndexEntry))
enumFortuneLocs :: Handle -> Char -> IO (IO (Maybe IndexEntry))
enumFortuneLocs file :: Handle
file delim :: Char
delim = do
    IORef Int
curStart <- Handle -> IO Integer
hTell Handle
file IO Integer -> (Integer -> IO (IORef Int)) -> IO (IORef Int)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (Int -> IO (IORef Int))
-> (Integer -> Int) -> Integer -> IO (IORef Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Int
forall a. Num a => Integer -> a
fromInteger
    IORef (Maybe (Int, Char, Int))
prev     <- Maybe (Int, Char, Int) -> IO (IORef (Maybe (Int, Char, Int)))
forall a. a -> IO (IORef a)
newIORef Maybe (Int, Char, Int)
forall a. Maybe a
Nothing
    IORef Int
curBytes <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef 0
    IORef Int
curChars <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef 0
    IORef Int
curLines <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef 0
    
    IO (Maybe (Int, Char, Int))
nextChar <- Handle -> IO (IO (Maybe (Int, Char, Int)))
enumUTF8 Handle
file
    
    let nextFortune :: IO (Maybe IndexEntry)
nextFortune = do
            Maybe (Int, Char, Int)
mbP <- IORef (Maybe (Int, Char, Int)) -> IO (Maybe (Int, Char, Int))
forall a. IORef a -> IO a
readIORef IORef (Maybe (Int, Char, Int))
prev
            Maybe (Int, Char, Int)
mbC <- IO (Maybe (Int, Char, Int))
nextChar
            IORef (Maybe (Int, Char, Int)) -> Maybe (Int, Char, Int) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe (Int, Char, Int))
prev Maybe (Int, Char, Int)
mbC
            
            case (Maybe (Int, Char, Int)
mbP, Maybe (Int, Char, Int)
mbC) of
                (Nothing, Nothing) -> Maybe IndexEntry -> IO (Maybe IndexEntry)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe IndexEntry
forall a. Maybe a
Nothing
                (Just (_, p, pN),  Nothing)
                     | Char
p Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\n'    -> Int -> Int -> IO (Maybe IndexEntry)
emit Int
pN 1
                     | Bool
otherwise    -> IO ()
newline IO () -> IO (Maybe IndexEntry) -> IO (Maybe IndexEntry)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Int -> IO (Maybe IndexEntry)
emit 0 0
                    
                (Just (_, p, pN), Just (_, c :: Char
c, n :: Int
n))
                    | Char
p Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\n' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
delim -> do
                        Maybe (Int, Char, Int)
mbN <- IO (Maybe (Int, Char, Int))
nextChar
                        case Maybe (Int, Char, Int)
mbN of 
                            Just (loc :: Int
loc,'\n',n :: Int
n) -> Int -> Int -> IO (Maybe IndexEntry)
emit Int
pN 1 IO (Maybe IndexEntry) -> IO () -> IO (Maybe IndexEntry)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Int -> IO ()
reset (Int
loc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n)
                            _ -> Int -> IO (Maybe IndexEntry)
advance Int
n
                (_, Just (_, c :: Char
c, n :: Int
n)) -> do
                    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\n') IO ()
newline
                    Int -> IO (Maybe IndexEntry)
advance Int
n
        newline :: IO ()
newline = IORef Int -> (Int -> Int) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef Int
curLines (1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+)
        advance :: Int -> IO (Maybe IndexEntry)
advance n :: Int
n = do
            IORef Int -> (Int -> Int) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef Int
curBytes (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+)
            IORef Int -> (Int -> Int) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef Int
curChars (1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+)
            IO (Maybe IndexEntry)
nextFortune
        reset :: Int -> IO ()
reset loc :: Int
loc = do
            IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Int
curStart (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$! Int
loc
            IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Int
curBytes 0
            IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Int
curChars 0
            IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Int
curLines 0
        -- the params are the amount to 'rewind' to cut off the final
        -- newline in a quote, if necessary
        emit :: Int -> Int -> IO (Maybe IndexEntry)
emit dB :: Int
dB dC :: Int
dC = do
            Int
start <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
curStart
            Int
bytes <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
curBytes
            Int
chars <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
curChars
            Int
ls    <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
curLines
                                
            Maybe IndexEntry -> IO (Maybe IndexEntry)
forall (m :: * -> *) a. Monad m => a -> m a
return (IndexEntry -> Maybe IndexEntry
forall a. a -> Maybe a
Just (Int -> Int -> Int -> Int -> IndexEntry
IndexEntry Int
start (Int
bytes Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
dB) (Int
chars Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
dC) Int
ls))
    
    IO (Maybe IndexEntry) -> IO (IO (Maybe IndexEntry))
forall (m :: * -> *) a. Monad m => a -> m a
return IO (Maybe IndexEntry)
nextFortune

#if !MIN_VERSION_base(4,6,0)

modifyIORef' r f = do
    x <- readIORef r
    writeIORef r $! f x

#endif

getByIndex :: Handle -> IndexEntry -> IO ByteString
getByIndex file :: Handle
file (IndexEntry loc :: Int
loc len :: Int
len _ _) = do
    Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
file SeekMode
AbsoluteSeek (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
loc)
    Handle -> Int -> IO ByteString
BS.hGet Handle
file Int
len

-- |@getFortune f i@ retrieves the text of the @i@'th fortune
-- (according to the order in the index file) in the 'FortuneFile' @f@.
getFortune :: FortuneFile -> Int -> IO T.Text
getFortune :: FortuneFile -> Int -> IO Text
getFortune f :: FortuneFile
f i :: Int
i = do
    Index
ix <- FortuneFile -> IO Index
getIndex FortuneFile
f
    IndexEntry
entry <- Index -> Int -> IO IndexEntry
getEntry Index
ix Int
i
    OnDecodeError -> ByteString -> Text
T.decodeUtf8With OnDecodeError
T.lenientDecode (ByteString -> Text) -> IO ByteString -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 
        FortuneFile -> (Handle -> IO ByteString) -> IO ByteString
forall b. FortuneFile -> (Handle -> IO b) -> IO b
withFortuneFile FortuneFile
f ((Handle -> IndexEntry -> IO ByteString)
-> IndexEntry -> Handle -> IO ByteString
forall a b c. (a -> b -> c) -> b -> a -> c
flip Handle -> IndexEntry -> IO ByteString
getByIndex IndexEntry
entry)

-- |Get the text of every fortune in a fortune file,
-- in the order they occur in the file.  Ignores the index
-- entirely.
getFortunes :: FortuneFile -> IO [T.Text]
getFortunes :: FortuneFile -> IO [Text]
getFortunes f :: FortuneFile
f = FortuneFile -> (Handle -> IO [Text]) -> IO [Text]
forall b. FortuneFile -> (Handle -> IO b) -> IO b
withFortuneFile FortuneFile
f ((Handle -> IO [Text]) -> IO [Text])
-> (Handle -> IO [Text]) -> IO [Text]
forall a b. (a -> b) -> a -> b
$ \file :: Handle
file -> do
    Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
file SeekMode
AbsoluteSeek 0
    Text -> Text -> [Text]
T.splitOn (FilePath -> Text
T.pack ['\n', FortuneFile -> Char
fortuneDelim FortuneFile
f, '\n']) (Text -> [Text]) -> IO Text -> IO [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> IO Text
T.hGetContents Handle
file

-- |Get the number of fortunes in a fortune file, as recorded
-- in the index.
getNumFortunes :: FortuneFile -> IO Int
getNumFortunes :: FortuneFile -> IO Int
getNumFortunes f :: FortuneFile
f = do
    Index
ix <- FortuneFile -> IO Index
getIndex FortuneFile
f
    Sum Int -> Int
forall a. Sum a -> a
getSum (Sum Int -> Int)
-> (FortuneStats -> Sum Int) -> FortuneStats -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FortuneStats -> Sum Int
numFortunes (FortuneStats -> Int) -> IO FortuneStats -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Index -> IO FortuneStats
getStats Index
ix

-- |Append a fortune to a fortune file, inserting a delimiter if
-- needed and updating the index.
appendFortune :: FortuneFile -> T.Text -> IO ()
appendFortune :: FortuneFile -> Text -> IO ()
appendFortune f :: FortuneFile
f fortune :: Text
fortune = do
    FortuneFile -> IO ()
rebuildIndex FortuneFile
f
    FortuneFile -> (Handle -> Index -> IO ()) -> IO ()
forall b. FortuneFile -> (Handle -> Index -> IO b) -> IO b
withFileAndIndex FortuneFile
f ((Handle -> Index -> IO ()) -> IO ())
-> (Handle -> Index -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \file :: Handle
file ix :: Index
ix -> do
        Int
offset <- Int -> Int -> Int
forall a. Ord a => a -> a -> a
max 0 (Int -> Int) -> (FortuneStats -> Int) -> FortuneStats -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Max Int -> Int
forall a. Max a -> a
getMax (Max Int -> Int)
-> (FortuneStats -> Max Int) -> FortuneStats -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FortuneStats -> Max Int
offsetAfter (FortuneStats -> Int) -> IO FortuneStats -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Index -> IO FortuneStats
getStats Index
ix
        Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
file SeekMode
AbsoluteSeek (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
offset)
        
        
        let enc :: Text -> ByteString
enc = Text -> ByteString
T.encodeUtf8
            sep :: ByteString
sep | Int
offset Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0   = ByteString
BS.empty
                | Bool
otherwise     = Text -> ByteString
enc (FilePath -> Text
T.pack ['\n', FortuneFile -> Char
fortuneDelim FortuneFile
f, '\n'])
            encoded :: ByteString
encoded = Text -> ByteString
enc Text
fortune
        
        Handle -> ByteString -> IO ()
BS.hPut Handle
file ByteString
sep
        Handle -> ByteString -> IO ()
BS.hPut Handle
file ByteString
encoded
        Handle -> ByteString -> IO ()
BS.hPut Handle
file (Text -> ByteString
enc (FilePath -> Text
T.pack "\n")) 
            -- just to be nice to people with @cat@s
        
        Handle -> IO ()
hFlush Handle
file
        
        Index -> IndexEntry -> IO ()
appendEntry Index
ix $WIndexEntry :: Int -> Int -> Int -> Int -> IndexEntry
IndexEntry
            { stringOffset :: Int
stringOffset  = Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
BS.length ByteString
sep
            , stringBytes :: Int
stringBytes   = ByteString -> Int
BS.length ByteString
encoded
            , stringChars :: Int
stringChars   = Text -> Int
T.length Text
fortune
            , stringLines :: Int
stringLines   = [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Text -> [Text]
T.lines Text
fortune)
            }