diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -14,8 +14,6 @@ misfortune-strfile path/to/file -Note that `misfortune` uses a different format for its index files than `fortune` does. If there is an existing fortune-mod index file, it will not be overwritten. - To use the fortune API in your Haskell programs: import Data.Fortune diff --git a/misfortune.cabal b/misfortune.cabal --- a/misfortune.cabal +++ b/misfortune.cabal @@ -1,5 +1,5 @@ name: misfortune -version: 0.1 +version: 0.1.1.1 stability: experimental cabal-version: >= 1.6 diff --git a/src/Data/Fortune.hs b/src/Data/Fortune.hs --- a/src/Data/Fortune.hs +++ b/src/Data/Fortune.hs @@ -226,7 +226,7 @@ then return "Very few profundities can be expressed in less than 80 characters." else randomFortune paths -randomFortune paths = withFortuneFiles paths '%' False $ \fs -> do +randomFortune paths = withFortuneFiles '%' False paths $ \fs -> do randomFortuneFromRandomFile . rvar =<< defaultFortuneDistribution fs -- |Select a random fortune file from a specified distribution and then select a @@ -250,9 +250,6 @@ | f <- fs ] --- TODO: allow the filter to assign a weight to each fortune, then weight the files --- by the total weight in their fortune-distributions (discarding zeros at both levels). - -- |Like 'defaultFortuneDistribution', but filtering the fortunes. In addition to the -- fortune file, the tuples in the distribution include a distribution over the -- matching fortune indices in that file, assigning equal weight to each. @@ -270,19 +267,19 @@ ] -- |Perform an action with an open 'FortuneFile', ensuring the file is closed --- when the action exits. -withFortuneFile :: FilePath -> Char -> Bool -> (FortuneFile -> IO a) -> IO a -withFortuneFile path delim writeMode = - bracket (openFortuneFile path delim writeMode) +-- when the action finishes. +withFortuneFile :: Char -> Bool -> FilePath -> (FortuneFile -> IO a) -> IO a +withFortuneFile delim writeMode path = + bracket (openFortuneFile delim writeMode path) closeFortuneFile -- |Perform an action with many open 'FortuneFile's, ensuring the files are closed --- when the action exits. -withFortuneFiles :: [FilePath] -> Char -> Bool -> ([FortuneFile] -> IO a) -> IO a -withFortuneFiles [] _ _ action = action [] -withFortuneFiles (p:ps) delim writeMode action = - withFortuneFile p delim writeMode $ \p -> - withFortuneFiles ps delim writeMode $ \ps -> +-- when the action finishes. +withFortuneFiles :: Char -> Bool -> [FilePath] -> ([FortuneFile] -> IO a) -> IO a +withFortuneFiles _ _ [] action = action [] +withFortuneFiles delim writeMode (p:ps) action = + withFortuneFile delim writeMode p $ \p -> + withFortuneFiles delim writeMode ps $ \ps -> action (p:ps) mapFortunesWithIndexM p f = diff --git a/src/Data/Fortune/FortuneFile.hs b/src/Data/Fortune/FortuneFile.hs --- a/src/Data/Fortune/FortuneFile.hs +++ b/src/Data/Fortune/FortuneFile.hs @@ -1,4 +1,6 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} module Data.Fortune.FortuneFile ( FortuneFile , fortuneFilePath @@ -52,21 +54,15 @@ -- 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 :: FilePath -> Char -> Bool -> IO FortuneFile -openFortuneFile path delim writeMode = do - exists <- doesFileExist path - when (not (exists || writeMode)) - (fail ("openFortuneFile: file does not exist: " ++ show path)) +openFortuneFile :: Char -> Bool -> FilePath -> IO FortuneFile +openFortuneFile fortuneDelim fortuneWritable fortunePath = do + exists <- doesFileExist fortunePath + when (not (exists || fortuneWritable)) + (fail ("openFortuneFile: file does not exist: " ++ show fortunePath)) - fileRef <- newMVar Nothing - ixRef <- newMVar Nothing - return FortuneFile - { fortunePath = path - , fortuneDelim = delim - , fortuneWritable = writeMode - , fortuneFile = fileRef - , fortuneIndex = ixRef - } + fortuneFile <- newMVar Nothing + fortuneIndex <- newMVar Nothing + return FortuneFile{..} -- |Close a fortune file. Subsequent accesses will fail. closeFortuneFile :: FortuneFile -> IO () @@ -167,6 +163,9 @@ return 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 bs = case U.decode bs of Just (c, n) | c /= U.replacement_char || n /= BS.length bs @@ -226,10 +225,14 @@ return nextFortune +#if !MIN_VERSION_base(4,6,0) + modifyIORef' r f = do x <- readIORef r writeIORef r $! f x +#endif + getByIndex file (IndexEntry loc len _ _) = do hSeek file AbsoluteSeek (toInteger loc) BS.hGet file len @@ -262,7 +265,6 @@ -- needed and updating the index. appendFortune :: FortuneFile -> T.Text -> IO () appendFortune f fortune = do - -- TODO: detect whether a reindex is actually needed rebuildIndex f withFileAndIndex f $ \file ix -> do offset <- max 0 . getMax . offsetAfter <$> getStats ix diff --git a/src/Data/Fortune/Index.hs b/src/Data/Fortune/Index.hs --- a/src/Data/Fortune/Index.hs +++ b/src/Data/Fortune/Index.hs @@ -214,7 +214,6 @@ checkIndex (Index file hdrRef) = either Just id <$> try (withMVar hdrRef (checkIndex_ file)) --- TODO: also random spot-check for validity of table entries (mostly that they are consistent with the stats). checkIndex_ file hdr = case checkHeader hdr of Just problem -> return (Just (HeaderProblem problem)) @@ -232,7 +231,6 @@ count = numFortunes (stats hdr) res <- action file base (getSum count) - -- TODO: build flag to control paranoia level? checkIndex_ file hdr >>= maybe (return res) throwIO @@ -243,7 +241,6 @@ hSeek file AbsoluteSeek 0 BS.hPut file (runPut (putHeader newHdr)) - -- TODO: build flag to control paranoia level? checkIndex_ file newHdr >>= maybe (return newHdr) throwIO -- |Get some cached stats about the fortunes indexed in this file. diff --git a/src/Fortune.hs b/src/Fortune.hs --- a/src/Fortune.hs +++ b/src/Fortune.hs @@ -81,17 +81,20 @@ data Length = Short | Long -type FortuneFilter = FortuneFile -> Int -> IndexEntry -> IO Bool +type FortuneFilter = FortuneFile -> Maybe (Int, IndexEntry) -> IO Bool data Args = Args { equalProb :: Bool , printDist :: Bool , dumpFortunes :: Maybe FilePath , fortuneFilters :: [FortuneFilter] - , threshold :: Threshold , fortuneFiles :: [FortuneFile] } +-- run all configured filters for an individual fortune +filterFile args file = andM [p file Nothing | p <- fortuneFilters args] +filterFortune args file i e = andM [p file (Just (i, e)) | p <- fortuneFilters args] + parseArgs = do (opts, files, errors) <- getOpt Permute flags <$> getArgs when (not (null errors)) (usage errors) @@ -105,21 +108,6 @@ when (Path `elem` opts) (printPath fortuneType) - let threshold = fromMaybe defaultThreshold (listToMaybe (opts >>= f)) - where f (LL n) = [Lines n]; f (N n) = [Chars n]; f _ = [] - - filterLength len _ _ e = return (checkThreshold threshold len (indexEntryStats e)) - filterRegex rx f i _ = matchTest rx . T.unpack <$> getFortune f i - - mkRegex :: String -> Regex - mkRegex = makeRegexOpts (compUTF8 + caseOpt) execBlank - where caseOpt = if I `elem` opts then compCaseless else 0 - - mkFilter L = Just (filterLength Long) - mkFilter S = Just (filterLength Short) - mkFilter (M rx) = Just (filterRegex (mkRegex rx)) - mkFilter _ = Nothing - fortuneFiles <- if null files then defaultFortuneFiles fortuneType else do @@ -131,25 +119,46 @@ else usage ["Fortune database not found: " ++ file | file <- missing] -- open them all - fortuneFiles <- mapM (\f -> openFortuneFile f '%' False) fortuneFiles - - -- pre-filter files based on stats in the headers. saves time filtering fortunes. - let lengthRestriction = listToMaybe (opts >>= f) - where f L = [Long]; f S = [Short]; f _ = [] - fortuneFiles <- filterFortuneFiles threshold lengthRestriction fortuneFiles + fortuneFiles <- mapM (openFortuneFile '%' False) fortuneFiles return Args { equalProb = E `elem` opts , printDist = F `elem` opts , dumpFortunes = listToMaybe [ path | D path <- opts ] - , fortuneFilters = catMaybes (map mkFilter opts) + , fortuneFilters = parseFilters opts , .. } -filterFortuneFiles threshold = - maybe return - (\r -> filterM (fmap (checkThreshold threshold r) . getStats <=< getIndex)) +parseFilters opts = mapMaybe (parseFilter opts) opts +parseFilter opts opt = case opt of + L -> Just (filterLength Long) + S -> Just (filterLength Short) + (M rx) -> Just (filterRegex (mkRegex rx)) + _ -> Nothing + where + filterLength len _ (Just (_, e)) = return (checkThreshold threshold len (indexEntryStats e)) + filterLength len f Nothing = checkThreshold threshold len <$> (getStats =<< getIndex f) + + filterRegex rx f (Just (i, _)) = matchTest rx . T.unpack <$> getFortune f i + filterRegex _ _ Nothing = return True + + mkRegex :: String -> Regex + mkRegex = makeRegexOpts (compUTF8 + caseOpt) execBlank + + caseOpt = if I `elem` opts then compCaseless else 0 + threshold = fromMaybe defaultThreshold (listToMaybe (opts >>= f)) + f (LL n) = [Lines n]; f (N n) = [Chars n]; f _ = [] + +-- longest one is long +checkThreshold t Long s = overThreshold t (maxChars s) (maxLines s) +-- shortest one is not long +checkThreshold t Short s = not (overThreshold t (minChars s) (minLines s)) + +overThreshold (Chars n) c l = c > n +overThreshold (Lines n) c l = l > n + + -- find a fortune file... 2 main cases: -- 1) the path is a simple name (contains no /'s): -- first check the given search path. @@ -163,8 +172,14 @@ -- offensive one, because the user didn't say "-o". -- 2) the path is not a simple name (contains at least one /): -- Just check for the file. -resolve searchPath fullSearchPath file = case splitPath file of - [_] -> do +resolve searchPath fullSearchPath file + | any (`elem` pathSeparators) file = do + exists <- doesFileExist file + return $! if exists + then Right [file] + else Left file + + | otherwise = do files <- findFortuneFileIn searchPath file if null files then do @@ -172,78 +187,56 @@ then findFortuneFileIn fullSearchPath file else return [] - if null files - then return (Left file) - else return (Right files) + return $! if null files + then Left file + else Right files else return (Right files) - _ -> do - exists <- doesFileExist file - if exists - then return (Right [file]) - else return (Left file) main = do args <- parseArgs - let fortunes = fortuneFiles args + -- pre-filter files that cannot possibly match. saves time filtering fortunes. + fortunes <- filterM (filterFile args) (fortuneFiles args) + dist <- getDist args fortunes + + when (numEvents dist == 0) $ do + hPutStrLn stderr "No fortunes matched the filter criteria" + exitWith (ExitFailure 2) + case dumpFortunes args of Nothing -> return () Just outPath -> do - out <- openFortuneFile outPath '%' True + out <- openFortuneFile '%' True outPath sequence_ - [ do - let allFilters i e = andM [p file i e | p <- fortuneFilters args] - selected <- filterFortunesWithIndexM allFilters file - sequence_ - [ getFortune file i >>= appendFortune out - | i <- selected - ] - | file <- fortunes + [ getFortune file i >>= appendFortune out + | (file, iDist) <- snd <$> toList dist + , i <- snd <$> toList iDist ] exitWith ExitSuccess - dist <- getDist args fortunes - - when (numEvents dist == 0) $ do - hPutStrLn stderr "No fortunes matched the filter criteria" - exitWith (ExitFailure 2) - if printDist args then sequence_ - -- TODO: merge paths into a tree for nicer presentation - [ printf "%5d %8s: %s\n" n pctStr (fortuneFilePath file) - | (weight, (file, n, _)) <- toList dist + [ printf "%5d %8s: %s\n" (numEvents iDist) pctStr (fortuneFilePath file) + | (weight, (file, iDist)) <- toList dist , let pctStr = printf "(%.2f%%)" (100 * weight / totalWeight dist) :: String ] else do - (file, _, fortuneDist) <- sample dist + (file, fortuneDist) <- sample dist fortune <- sample fortuneDist - -- putStrLn (fortuneFilePath file ++ " - " ++ show fortune) putStrLn . T.unpack =<< getFortune file fortune --- longest one is long -checkThreshold t Long s = overThreshold t (maxChars s) (maxLines s) --- shortest one is not long -checkThreshold t Short s = not (overThreshold t (minChars s) (minLines s)) - -overThreshold (Chars n) c l = c > n -overThreshold (Lines n) c l = l > n - -getDist :: Args -> [FortuneFile] -> IO (Categorical Float (FortuneFile, Int, RVar Int)) +getDist :: Args -> [FortuneFile] -> IO (Categorical Float (FortuneFile, Categorical Float Int)) getDist args files = equalize <$> case fortuneFilters args of [] -> do dist <- defaultFortuneDistribution files let f file = do n <- getNumFortunes file - return (file, n, uniform 0 (n-1)) + return (file, fromObservations [0 .. n-1]) T.mapM f dist - filters -> do - dist <- fortuneDistributionWhere (\f i e -> andM [p f i e | p <- filters]) files - let f (file, iDist) = (file, numEvents iDist, rvar iDist) - return (fmap f dist) + _ -> fortuneDistributionWhere (filterFortune args) files where equalize | equalProb args = mapCategoricalPs (const 1) diff --git a/src/StrFile.hs b/src/StrFile.hs --- a/src/StrFile.hs +++ b/src/StrFile.hs @@ -8,6 +8,6 @@ mapM_ index args index file = do - fortune <- openFortuneFile file '%' True + fortune <- openFortuneFile '%' True file rebuildIndex fortune