Snusmumrik (empty) → 0.0.1
raw patch · 13 files changed
+1203/−0 lines, 13 filesdep +HDBCdep +HDBC-sqlite3dep +HFusesetup-changed
Dependencies added: HDBC, HDBC-sqlite3, HFuse, LibZip, base, bytestring, convertible, directory, filepath, haskell98, hslogger, iconv, regex-tdfa, stm, unix, utf8-string, xml
Files
- Book.hs +79/−0
- DB.hs +335/−0
- FB2.hs +141/−0
- FileStats.hs +67/−0
- LICENSE +25/−0
- README +37/−0
- Setup.lhs +3/−0
- Snusmumrik.cabal +86/−0
- TODO +10/−0
- Utils.hs +116/−0
- Views.hs +23/−0
- mumrik.hs +233/−0
- snus.hs +48/−0
+ Book.hs view
@@ -0,0 +1,79 @@+module Book+ ( Book(..), readBookInfo, unknownBook+ , bookFileName, titleFromFileName ) where++import Data.ByteString.Lazy.Internal (smallChunkSize)+import Data.List (intercalate)+import System.FilePath (makeValid, takeBaseName)+import Text.Regex.TDFA ((=~))++import FB2+import Utils++-- TODO: consider structured author+data Book = Book {+ authors :: [String]+ , title :: String+ , genres :: [String]+ , date :: String+ , lang :: String+ , archive :: String+ , path :: String+ , size :: Int+ } deriving (Eq)++instance Show Book where+ show b = unlines $+ [ (intercalate ", " $ authors b) ++ " /"+ , " " ++ title b+ , " " ++ date b+ , " " ++ (intercalate " " $ genres b)+ , " lang : " ++ lang b+ , " in : " ++ (archive b) ++ " : " ++ (path b)+ ]++unknownBook :: Book+unknownBook = Book {+ authors = []+ , title = ""+ , genres = []+ , date = ""+ , lang = ""+ , archive = ""+ , path = ""+ , size = 0+ }++readBookInfo :: String -> Book+readBookInfo bytes =+ let -- in FB2 all meta data is usually in the beginning,+ -- we don't need to parse everything, smallChunkSize is just a guess (4k)+ -- which seems to work on most of the real-world files+ doc = convParseXml $ take smallChunkSize bytes+ t = getTitle doc+ as = getAuthors doc+ g = getGenres doc+ l = getLang doc+ d = getDate doc+ sz = length bytes+ in unknownBook { authors = as, title = t, genres = g+ , lang = l, date = d, size = sz }++-- | Standard template for book files.+bookFileName :: Book -> String+bookFileName book =+ let t = title book+ as = intercalate ", " . filter (not . null) $ authors book+ bookname = takeBaseName $ path book+ year = wrap (" (") (")") (date book)+ wrap b a what | null what = ""+ | otherwise = b ++ what ++ a+ filename = intercalate " ~ " . filter (not . null)+ $ [ t, (as ++ year), (bookname ++ ".fb2") ]+ in makeValid . fixname $ filename++-- | Extract title template from filename+titleFromFileName :: String -> String+titleFromFileName n = let (t,_,_) = n =~ " ~ " :: (String,String,String)+ in unfixname t+
+ DB.hs view
@@ -0,0 +1,335 @@+{-# LANGUAGE FlexibleContexts #-}+module DB+ ( initDB, insertBook+ , findAuthorInitials, findAuthors, findGenres, findLangs, findBooks+ , Connection(), clone, commit, rollback, withTransaction, disconnect+ , catchSql, SqlError(..)) where++import Control.Applicative ((<$>))+import Data.Char (toUpper, toLower)+import Data.List (sort, nub, foldl1', inits, tails, intercalate, intersperse)+import Data.Maybe (maybeToList)+import System.FilePath+import System.Directory+import Text.Regex.TDFA ((=~))++import Database.HDBC+import Database.HDBC.Sqlite3+import Data.Convertible.Base (Convertible)++import Book+import Utils+import Views++dbdir :: IO FilePath+dbdir = getAppUserDataDirectory "snusmumrik"++dbfile :: IO FilePath+dbfile = do+ dir <- dbdir+ return $ dir </> "library.sqlite"++initDB :: IO Connection+initDB = do+ dir <- dbdir+ createDirectoryIfMissing True dir+ file <- dbfile+ db <- connectSqlite3 file+ createTables db+ return db++-- TODO: normalize DB schema, e.g. many authors, genres, langs per book++createTables :: Connection -> IO ()+createTables db = do+ run db "create table if not exists \+ \ books ( \+ \ id INTEGER PRIMARY KEY AUTOINCREMENT, \+ \ title TEXT, \+ \ lang TEXT, \+ \ date TEXT, \+ \ archive TEXT, \+ \ path TEXT, \+ \ size INTEGER, \+ \ unique (archive, path) on conflict ignore )" []+ run db "create table if not exists \+ \ authors ( \+ \ id INTEGER PRIMARY KEY AUTOINCREMENT, \+ \ name TEXT unique on conflict ignore)" []+ run db "create table if not exists \+ \ bookauthors ( \+ \ author_id INTEGER REFERENCES authors, \+ \ book_id INTEGER REFERENCES books)" []+ run db "create table if not exists \+ \ genres ( \+ \ id INTEGER PRIMARY KEY AUTOINCREMENT, \+ \ genre TEXT unique on conflict ignore)" []+ run db "create table if not exists \+ \ bookgenres ( \+ \ genre_id INTEGER REFERENCES genres, \+ \ book_id INTEGER REFERENCES books)" []+ run db "create index if not exists \+ \ authorix on authors ( name )" []+ run db "create index if not exists \+ \ titleix on books ( title )" []+ run db "create index if not exists \+ \ genreix on genres ( genre )" []+ run db "create index if not exists \+ \ locationix on books ( archive, path )" []+ run db "create index if not exists \+ \ bookauthorix1 on bookauthors (author_id, book_id)" []+ run db "create index if not exists \+ \ bookauthorix2 on bookauthors (book_id, author_id)" []+ run db "create index if not exists \+ \ bookgenresix1 on bookgenres (genre_id, book_id)" []+ run db "create index if not exists \+ \ bookgenresix2 on bookgenres (book_id,genre_id)" []+ return ()++insertBook :: Connection -> Book -> IO ()+insertBook db book = do+ -- insert book+ run db "insert into books \+ \ ( title, lang, date, size, archive, path ) \+ \ values ( ?, ?, ?, ?, ?, ?)" bookValues+ -- or update+ -- TODO: implement DB update+ -- insert authors+ insertAuthors <- prepare db "insert into authors ( name ) values ( ? )"+ executeMany insertAuthors $ map (:[]) $ authorNames+ -- authors to books correspondence+ insertBookAuthors <- prepare db $ "insert into bookauthors \+ \ ( author_id, book_id ) \+ \ select authors.id, books.id \+ \ from authors, books \+ \ where books.archive = ? and books.path = ? \+ \ and authors.name = ?"+ executeMany insertBookAuthors bookAuthors+ -- insert genres+ insertGenre <- prepare db "insert into genres ( genre ) values ( ? )"+ executeMany insertGenre $ map (:[]) genreNames+ -- genres to books correspondence+ insertBookGenres <- prepare db $ "insert into bookgenres \+ \ ( genre_id, book_id ) \+ \ select g.id, b.id \+ \ from genres g, books b \+ \ where b.archive = ? and b.path = ? \+ \ and g.genre = ?"+ executeMany insertBookGenres bookGenres+ return ()+ where bookValues = (map fToSql [ title, lang, date ])+ ++ [fToSql size]+ ++ (map fToSql [ archive, path ])+ fToSql :: (Convertible a SqlValue) => (Book -> a) -> SqlValue+ fToSql f = toSql $ f book+ -- archive, path must be last:+ bookLoc = reverse . take 2 . reverse $ bookValues+ authorNames :: [SqlValue]+ authorNames = map toSql $ authors book+ bookAuthors :: [[SqlValue]]+ bookAuthors = map (\a -> bookLoc ++ [a]) authorNames+ genreNames :: [SqlValue]+ genreNames = map toSql $ genres book+ bookGenres :: [[SqlValue]]+ bookGenres = map (\g -> bookLoc ++ [g]) genreNames++-- | Find initials of all authors who satisfy given choices.+findAuthorInitials :: Connection -> [String] -> [View] -> IO [String]+findAuthorInitials _ cs _ | dbg ("findAuthorInitials: " ++ (showL' cs)) = stub+findAuthorInitials db choices views = do+ let qsort = "order by authors.name"+ let (q,params) = buildQuery AuthorInitial choices views []+ rows <- quickQuery' db (trace' (q ++ qsort)) params ::IO [[SqlValue]]+ let names = onlyJusts . map fromSql . column 0 $ rows+ let inis = nub . map (replaceX . toLower) . concatMap head' $ names+ return . trace' . map (:[]) $ inis+ where+ replaceX c | (toLower c) `notElem` romanOrCyrillic = '_'+ | otherwise = c+ head' :: [a] -> [a]+ head' [] = []+ head' (x:_) = [x]++-- sqlite does not support case conversion nor cares enough about char ranges+romanOrCyrillic :: [Char]+romanOrCyrillic = ['a'..'z'] ++ ['а'..'я'] ++ ['ё']+-- hack around sqlite limitations and HDBC not being friendly with substr()+startsWith :: [Char] -> String -> String+startsWith chars what =+ let chars' = (map toLower chars) ++ (map toUpper chars)+ anyStart = intercalate " or " $ map (\x->what++" like '"++[x]++"%'") chars'+ in "( " ++ anyStart ++ " )"++-- | Find all authors who satisfy given choices.+findAuthors :: Connection -> [String] -> [View] -> IO [String]+findAuthors _ cs _ | dbg ("findAuthors: " ++ (showL' cs)) = stub+findAuthors db choices views = do+ let qsort = "order by authors.name"+ let (q,params) = buildQuery Author choices views []+ rows <- quickQuery' db (trace' (q ++ qsort)) (trace' params) :: IO [[SqlValue]]+ return . map fixname . onlyJusts . map fromSql . column 1 $ rows++-- | Find all books which satisfy given choices.+findGenres :: Connection -> [String] -> [View] -> IO [String]+findGenres _ cs _ | dbg ("findGenres: " ++ (showL' cs)) = stub+findGenres db choices views = do+ -- only genres with 50+ books (avoids most of the inconsistent metadata)+ let qgroup = "group by genres.id \+ \having count(bookgenres.book_id) > 50 \+ \order by genres.genre"+ let (q,params) = buildQuery Genre choices views ["bookgenres"]+ rows <- quickQuery' db (trace' (q ++ qgroup)) (trace' params) :: IO [[SqlValue]]+ return . map fixname . onlyJusts . map fromSql . column 1 $ rows++findLangs :: Connection -> [String] -> [View] -> IO [String]+findLangs _ cs _ | dbg ("findLangs: " ++ (showL' cs)) = stub+findLangs db choices views = do+ let (q,params) = buildQuery Lang choices views []+ rows <- quickQuery' db (trace' q) (trace' params) :: IO [[SqlValue]]+ let langs = onlyJusts . map fromSql . column 0 $ rows+ -- skip languages which are not two-letter lower-case codes+ return . map fixname . filter ( =~ "^[a-z]{2}$") $ langs++-- | Find all books which satisfy given choices.+findBooks :: Connection -> [String] -> [View] -> IO [Book]+findBooks _ cs _ | dbg ("findBooks: " ++ (showL' cs)) = stub+findBooks db choices views = do+ let qsort = "order by books.title"+ let (q,params) = buildQuery (last views) choices views []+ rows <- quickQuery' db (trace' (q ++ qsort)) (trace' params) :: IO [[SqlValue]]+ let books = onlyJusts $ map toBook rows :: [(Int,Book)]+ mapM (addAuthorsAndGenres db) books :: IO [Book]++buildQuery :: View -- ^ what is requested+ -> [String] -- ^ choices made+ -> [View] -- ^ views for previous choices+ -> [String] -- ^ extra table to select from, usually []+ -> (String,[SqlValue]) -- ^ (query, positional params)+buildQuery w cs ss _+ | dbg ("buildQuery: " ++ (show w) ++ " " ++ (show $ zip cs ss)) = stub+buildQuery what choices views xtratables =+ let cvs = zip choices views+ predicates = map fromWhere cvs+ (begin,basetbl) = selectCols what+ joins = joinWhere $ basetbl:(concatMap fst3 predicates) ++ xtratables+ fws = joinClauses $ joins:predicates+ tables = nub $ basetbl:(fst3 fws) ++ xtratables+ q = intercalate " " $ [begin]+ ++ ("from":(intersperse "," tables))+ ++ (whereClause $ snd3 fws)+ in (q ++ " ", map toSql $ trd3 fws)+ where+ -- column order is important, some fragile code depends on it (see column)+ selectCols (Author) = ( "select distinct authors.id, authors.name"+ , "authors" )+ selectCols (AuthorInitial) = ( "select distinct authors.name"+ , "authors" )+ selectCols (Title) = ( "select distinct books.id, books.title, books.lang, \+ \ books.date, books.archive, books.path, books.size"+ , "books" )+ selectCols (Genre) = ( "select distinct genres.id, genres.genre"+ , "genres" )+ selectCols (Lang) = ( "select distinct books.lang", "books" )+ whereClause [] = [""]+ whereClause ps = "where":(intersperse "and" ps)++-- | Produce predicative clauses as ([tables],[conditions],[positional_params])+fromWhere :: (String,View) -> ([String],[String],[String])+fromWhere (c, Author) =+ ( ["authors"]+ , ["authors.name = ?"]+ , [unfixname c])+fromWhere (c, Genre) =+ ( ["genres"]+ , ["genres.genre = ?"]+ , [unfixname c])+fromWhere (c, Lang) =+ ( ["books"]+ , ["books.lang = ?"]+ , [c])+fromWhere (c, Title) =+ let n = unfixname $ titleFromFileName c in+ ( ["books"]+ , ["books.title = ?"]+ , [unfixname n])+fromWhere (c:_, AuthorInitial)+ | c /= '_' = ( ["authors"]+ , [ "(authors.name like ? or authors.name like ?)"]+ , [ (toLower c):"%", (toUpper c):"%" ])+ | c == '_' = ( ["authors"]+ , ["not " ++ (startsWith romanOrCyrillic "authors.name")]+ , [])+fromWhere _ = ([], [], [])++-- | Produce join clauses as ([tables],[conditions],[positional_params])+joinWhere :: [String] -- ^ tables used+ -> ([String],[String],[String]) -- ^ necessary join clause+joinWhere tables =+ let joins = map (uncurry joinWhere') (combos tables)+ in joinClauses joins+ where+ combos xs =+ let xs' = nub . sort $ xs+ in if length xs' < 2+ then [] -- nothing to join+ else [ (last h,t') | (h,t) <- init.tail $ zip (inits xs') (tails xs')+ , t' <- t ]+ joinWhere' "authors" "books" = ( [ "authors", "bookauthors", "books" ]+ , [ "authors.id = bookauthors.author_id"+ , "bookauthors.book_id = books.id" ]+ , [])+ joinWhere' "authors" "genres" = ( [ "authors", "bookauthors", "bookgenres", "genres" ]+ , [ "authors.id = bookauthors.author_id"+ , "bookauthors.book_id = bookgenres.book_id"+ , "bookgenres.genre_id = genres.id" ]+ , [])+ joinWhere' "books" "genres" = ( [ "genres", "bookgenres", "books" ]+ , [ "genres.id = bookgenres.genre_id"+ , "bookgenres.book_id = books.id" ]+ , [])+ joinWhere' "bookgenres" "genres" = ( [ "genres", "bookgenres" ]+ , [ "genres.id = bookgenres.genre_id" ]+ , [])+ joinWhere' _ _ = ([], [], [])++joinClauses :: [([String],[String],[String])] -> ([String],[String],[String])+joinClauses [] = ([], [], [])+joinClauses cs = foldl1' (liftT2 (++)) cs++addAuthorsAndGenres :: Connection -> (Int, Book) -> IO Book+addAuthorsAndGenres _ b | dbg ("addAuthorsAndGenres: " ++ (show $ fst b)) = stub+addAuthorsAndGenres db (bid, book) = do+ let authorsQ = "select distinct a.name \+ \ from authors a \+ \ join bookauthors ba on a.id = ba.author_id \+ \ where ba.book_id = ? \+ \ order by a.name"+ let genresQ = "select distinct g.genre \+ \ from genres g \+ \ join bookgenres bg on bg.genre_id = g.id \+ \ where bg.book_id = ? \+ \ order by g.genre"+ authors' <- column 0 <$> quickQuery' db authorsQ [toSql bid]+ genres' <- column 0 <$> quickQuery' db genresQ [toSql bid]+ return $ book { authors = sort $ map fromSql authors'+ , genres = sort $ map fromSql genres' }++toBook :: [SqlValue] -> Maybe (Int, Book)+toBook vs | length vs /= 7 = Nothing+toBook [id',title',lang',date',archive',path',size']+ | otherwise =+ let book = unknownBook {+ title = fromSql title'+ , date = fromSql date'+ , lang = fromSql lang'+ , archive = fromSql archive'+ , path = fromSql path'+ , size = fromSql size' }+ in Just (fromSql id', book)+toBook _ = Nothing++onlyJusts :: [Maybe a] -> [a]+onlyJusts = concatMap maybeToList++column :: Int -> [[a]] -> [a]+column n xss = onlyJusts $ map (maybeNth n) xss
+ FB2.hs view
@@ -0,0 +1,141 @@+module FB2+ ( readByteFile, convParseXml+ , getAuthors, getTitle, getGenres+ , getLang, getDate) where++import qualified Data.ByteString.Lazy.Char8 as Lazy+import Data.ByteString.Lazy.UTF8 (toString)++import Data.Char (isSpace)+import Data.List (intercalate)+import Data.Maybe (maybeToList,listToMaybe,fromMaybe)++import Text.XML.Light+import Codec.Text.IConv (convertFuzzy,Fuzzy(..))++{-+import System.Environment (getArgs)+import Control.Monad (mapM_, forM_)+import Data.ByteString.Lazy.Internal (smallChunkSize)+main = getArgs >>= mapM_ showInfo++showInfo fname = do+ raw <- readByteFile fname+ let doc = convParseXml $ take smallChunkSize raw -- metainfo is in the beginning+ let t = getTitle doc+ let a = getAuthors doc+ let g = getGenres doc+ let l = getLang doc+ let d = getDate doc+ putStrLn $ intercalate ", " a+ putStrLn $ " " ++ t+ putStrLn $ " " ++ d+ putStrLn $ " G: " ++ (intercalate ", " g)+ putStrLn $ " L: " ++ l+-}++-- | Read file as a sequence of bytes.+readByteFile :: String -> IO String+readByteFile f = return . Lazy.unpack =<< Lazy.readFile f++-- | Convert XML according to document encoding and parse it.+convParseXml :: String -> [Element]+convParseXml s =+ let doc = onlyElems . parseXML $ s+ elm1 = head doc+ convertFrom :: String -> String -> String+ convertFrom enc = toString . convertFuzzy Transliterate enc "UTF-8" . Lazy.pack+ in+ if (qName . elName $ elm1) /= "?xml"+ then doc+ else case findAttr (unqual "encoding") elm1 of+ Nothing -> doc+ Just enc -> onlyElems . parseXML . convertFrom enc $ s++--+-- FB2 XML machinery+--++fbURL :: Maybe String+fbURL = Just "http://www.gribuser.ru/xml/fictionbook/2.0"+fbname :: String -> QName+fbname name = QName name fbURL Nothing++type Filter = [Element] -> [Element]++-- | All descendent sub-elements with a given name.+subElems :: String -> Filter+subElems name elms = concatMap (findElements (fbname name)) elms++-- | All text contents of given elements.+txt :: [Element] -> [String]+txt elms = map cdData . concatMap (onlyText . elContent) $ elms++-- | Attribute value.+attr :: String -> Element -> Maybe String+attr name elm = findAttr (fbname name) elm++getPath :: [String] -> Filter+getPath names elms =+ let follow = foldl (\f n -> \els-> subElems n $ f els) id' names :: Filter+ id' = id :: Filter+ in follow elms++-- | Text contents or attrubute values located by given path.+-- If the last name in the path starts with @, lookup attribute value.+getValues :: [String] -> [Element] -> [String]+getValues [] _ = []+getValues path elms =+ let tip = last path+ path' = init path -- if the last item in path is attribute name+ in case tip of+ '@':name -> concatMap maybeToList . map (attr name) . getPath path' $ elms+ _ -> txt . getPath path $ elms++--+-- FB2 meta information readers+--++metaPath :: [String]+metaPath = [ "FictionBook", "description", "title-info" ]+authorPath :: [String]+authorPath = metaPath ++ [ "author" ]+booktitlePath :: [String]+booktitlePath = metaPath ++ [ "book-title" ]+genrePath :: [String]+genrePath = metaPath ++ [ "genre" ]+langPath :: [String]+langPath = metaPath ++ [ "lang" ]+datePath :: [String]+datePath = metaPath ++ [ "date" ]++getTitle :: [Element] -> String+getTitle doc = strip $ firstOrEmpty $ getValues booktitlePath doc++getAuthors :: [Element] -> [String]+getAuthors doc = map getAuthor . getPath authorPath $ doc+ where getAuthor :: Element -> String+ getAuthor e =+ let ln = map strip $ getValues ["last-name"] [e]+ fn = map strip $ getValues ["first-name"] [e]+ mn = map strip $ getValues ["middle-name"] [e]+ in intercalate " " $ ln ++ fn ++ mn++getGenres :: [Element] -> [String]+getGenres doc = map strip $ getValues genrePath doc++getLang :: [Element] -> String+getLang doc = strip $ firstOrEmpty $ getValues langPath doc++getDate :: [Element] -> String+getDate doc = strip $ firstOrEmpty $ getValues datePath doc++--+-- Utilities+--++strip :: String -> String+strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse++firstOrEmpty :: [String] -> String+firstOrEmpty = fromMaybe "" . listToMaybe
+ FileStats.hs view
@@ -0,0 +1,67 @@+-- | Default access rights for files and directories+module FileStats (defaultStats, bookStats) where++import System.Fuse+import System.Posix.User+import System.Posix.Files+import System.Posix.Types (FileMode)++import Book++-- | returns default FileStat for library files and library directories respectively+defaultStats :: IO (FileStat, FileStat) -- ^ IO (defaultFileStat, defaultDirStat)+defaultStats = do+ defaultFile <- effectiveUser defaultFileStat+ defaultDir <- effectiveUser defaultDirStat+ return (defaultFile, defaultDir)++effectiveUser :: FileStat -> IO FileStat+effectiveUser stat = do+ uid <- getEffectiveUserID+ gid <- getEffectiveGroupID+ return $ stat { statFileOwner = uid, statFileGroup = gid }++defaultDirStat :: FileStat+defaultDirStat = FileStat {+ statEntryType = Directory+ , statFileMode = defaultDirMode+ , statLinkCount = 0+ , statFileOwner = 0 -- please override+ , statFileGroup = 0 -- please override+ , statSpecialDeviceID = 0+ , statFileSize = 0+ , statBlocks = 0+ , statAccessTime = 0+ , statModificationTime = 0+ , statStatusChangeTime = 0+ }++defaultDirMode :: FileMode+defaultDirMode = foldr unionFileModes (entryTypeToFileMode Directory)+ [ ownerReadMode, ownerExecuteMode, groupReadMode, groupExecuteMode ]++defaultFileStat :: FileStat+defaultFileStat = FileStat {+ statEntryType = RegularFile+ , statFileMode = defaultFileMode+ , statLinkCount = 1+ , statFileOwner = 0 -- please override+ , statFileGroup = 0 -- please override+ , statSpecialDeviceID = 0+ , statFileSize = 0+ , statBlocks = 0+ , statAccessTime = 0+ , statModificationTime = 0+ , statStatusChangeTime = 0+ }++defaultFileMode :: FileMode+defaultFileMode = foldr unionFileModes (entryTypeToFileMode RegularFile)+ [ ownerReadMode, groupReadMode ]++-- | Update file stats according to book's metadata.+bookStats :: FileStat -> Book -> FileStat+bookStats stats b = let sz = size b+ in stats { statFileSize = fromIntegral sz+ , statBlocks = ceiling ((toRational sz) / 512) }+
+ LICENSE view
@@ -0,0 +1,25 @@+Copyright (c) 2009, Sergey Astanin+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright notice,+ this list of conditions and the following disclaimer.+ * Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.+ * Neither the name of the Sergey Astanin nor the names of other+ contributors may be used to endorse or promote products derived from this+ software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README view
@@ -0,0 +1,37 @@+Snusmumrik+==========++Version 0.0.1 “T-Shirt”++A cyber-anarchist e-library directory based on [FUSE][fuse] virtual file system.+It is intended to work with [FB2][fb2] e-book archives in the first place.++Today it consists of two tools:++ snus [path/to/archive.zip]++ add archive.zip with book files to the index (~/.snusmumrik)++ FB2 is today the only supported e-book format.++ mumrik path/to/mount/point++ mount the library directory at the given point++ (to unmount use `fusermount -u path/to/mount/point`)++Please see the [Wiki][wiki] for further information.++About the name+~~~~~~~~~~~~~~++Snusmumrik is a Russian name for [Snufkin][snufkin] (Swedish: Snusmumriken),+a character in the Moomin series of books by Tove Jansson. Snufkin dislikes+all symbols of private property, forbidding signs and fenced lawns. He likes+travelling, living in a tent, smoking a pipe and playing the harmonica.+++[fuse]: http://fuse.sourceforge.net/+[fb2]: http://en.wikipedia.org/wiki/FictionBook+[wiki]: http://bitbucket.org/jetxee/snusmumrik/wiki/Home+[snufkin]: http://en.wikipedia.org/wiki/Snufkin
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ Snusmumrik.cabal view
@@ -0,0 +1,86 @@+Name: Snusmumrik+Version: 0.0.1+Cabal-version: >= 1.2+Build-type: Simple++Synopsis: E-library directory based on FUSE virtual file system.+Description:+ A cyber-anarchist e-library directory based on FUSE virtual file system.+ It is intended to work with FB2 (FictionBook2) e-book archives in the first+ place. Other e-book formats and archive layouts may be implemented later.+ .+ Today Snusmumrik consists of two utilities, `snus` to index archives and+ `mumrik` to mount library directory at given mount point. Mounted directory+ is organized by author name, by genre and by language.++Stability: experimental+Category: Text+License: BSD3+License-file: LICENSE+Homepage: http://bitbucket.org/jetxee/snusmumrik/+Bug-reports: http://bitbucket.org/jetxee/snusmumrik/issues/+Maintainer: Sergey Astanin <s.astanin@gmail.com>++Tested-with: GHC == 6.10+Extra-source-files: README, TODO++Flag debug+ Description: Enable debug support and noisy (-Wall) compilation.+ Default: False++Executable snus+ Main-is: snus.hs+ Other-Modules: DB, Book, FB2, Utils, Views+ Extra-Libraries: zip+ Build-Tools: cpphs+ Extensions: CPP+ GHC-Options: -pgmPcpphs -optP--cpp+ Build-depends:+ haskell98+ , base >= 3 && < 5+ , filepath+ , directory+ , bytestring+ , utf8-string+ , iconv+ , regex-tdfa+ , HDBC+ , HDBC-sqlite3+ , convertible+ , LibZip >= 0.0.2 && < 0.1+ , xml+ , hslogger++ if flag(debug)+ GHC-Options: -Wall+ CPP-Options: -DDEBUGBUILD++Executable mumrik+ Main-is: mumrik.hs+ Other-Modules: FileStats, Book, DB, Views, Utils+ Extra-Libraries: zip+ Build-Tools: cpphs+ Extensions: CPP+ GHC-Options: -threaded -pgmPcpphs -optP--cpp+ Build-depends:+ haskell98+ , base >= 3 && < 5+ , filepath+ , directory+ , bytestring+ , utf8-string+ , iconv+ , regex-tdfa+ , HDBC+ , HDBC-sqlite3+ , convertible+ , stm+ , LibZip >= 0.0.2 && < 0.1+ , unix+ , HFuse >= 0.2.1+ , hslogger++ if flag(debug)+ CPP-Options: -DDEBUGBUILD+ GHC-Options: -Wall+
+ TODO view
@@ -0,0 +1,10 @@+TODO+====++* Rewrite LibZip bindings without c2hs to make thing buildable on GHC >= 6.12+* Shorten books' filenames for compatibility with legacy file systems (FAT)+* Web interface (instead or in addition to FUSE-fs)+* Indexer (snus) should be able to update the index (not only add new archives)+* Indexer (snus) should be able to index also usual directories (not archives)+* E-book formats other than FB2 to be supported (ePub? FB3? Mobipocket?)+* Fix #1
+ Utils.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE CPP #-}+module Utils where++import Codec.Binary.UTF8.String (encodeString)+import Data.List (intercalate)+import Data.Maybe (fromMaybe)++-- for daemonTrace+import System.IO.Unsafe (unsafePerformIO)+import System.Log.Logger++-- | Safe 'head'.+maybeHead :: [a] -> Maybe a+maybeHead [] = Nothing+maybeHead (x:_) = Just x++-- | Safe substitute for (!!).+maybeNth :: Int -> [a] -> Maybe a+maybeNth _ [] = Nothing+maybeNth 0 xs = maybeHead xs+maybeNth n (_:xs) = maybeNth (n-1) xs++-- | Safe 'last'.+maybeLast :: [a] -> Maybe a+maybeLast [] = Nothing+maybeLast xs = Just $ last xs++-- | Extract the first component of a triplet.+fst3 :: (a,b,c) -> a+fst3 (x,_,_) = x++-- | Extract the second component of a triplet.+snd3 :: (a,b,c) -> b+snd3 (_,y,_) = y++-- | Extract the third component of a triplet.+trd3 :: (a,b,c) -> c+trd3 (_,_,z) = z++-- | Apply function of 2 arguments to triplets' elements.+liftT2 :: (a -> b -> c) -> (a,a,a) -> (b,b,b) -> (c,c,c)+liftT2 f (x,y,z) (x',y',z') = (f x x', f y y', f z z')++-- | Encode forbidden file names with trigraphs and substitutions+fixname :: String -> String+fixname "" = "нет имени"+fixname name = concatMap tr name+ where tr c = fromMaybe [c] $ lookup c fixnameTable++-- | Inverse of 'fixname'. Hopefully (unfixname . fixname == id).+unfixname :: String -> String+unfixname "нет имени" = ""+unfixname name = unescape name+ where unescape [] = []+ unescape s@('_':_:_:rest) =+ let esc = take 3 s+ unesc = fromMaybe esc . lookup esc $ unfixnameTable+ -- ^^^ leave as is if name is incorrect+ in unesc ++ (unescape rest)+ unescape (x:rest) = x:(unescape rest)++-- Symbols forbidden in WinXP filenames: \ / : * ? " < > |+fixnameTable :: [(Char,String)]+fixnameTable =+ [ ( '\\', "_Z_" )+ , ( '/', "_%_" )+ , ( ':', "_=_" )+ , ( '*', "_x_" )+ , ( '?', "_7_" )+ , ( '"', "_'_" )+ , ( '<', "_(_" )+ , ( '>', "_)_" )+ , ( '|', "_I_" )+ , ( '_', "___" ) ]++unfixnameTable :: [(String,String)]+unfixnameTable = map (sndSingleton . swap) fixnameTable+ where swap (k,v) = (v,k)+ sndSingleton (x,y) = (x,[y])++-- | Debug tracing. To be used+dbg :: String -> Bool+#ifdef DEBUGBUILD+dbg msg = daemonTrace (encodeString msg) False+#else+dbg _ = False+#endif++-- | Debug tracing.+trace' :: (Show a) => a -> a+#ifdef DEBUGBUILD+trace' x = daemonTrace (show x) x+#else+trace' = id+#endif++#ifdef DEBUGBUILD+{-# NOINLINE daemonTrace #-}+-- | daemonTrace is a replacement for Debug.Trace.trace.+daemonTrace :: String -- ^ log message+ -> a -> a+daemonTrace msg value = unsafePerformIO $ do+ debugM rootLoggerName msg+ return value+#endif++showL :: String -> [String] -> String+showL "" xs = "[" ++ (intercalate ", " xs) ++ "]"+showL name xs = name ++ " = " ++ (showL "" xs)++showL' :: [String] -> String+showL' = showL ""++stub :: anytype+stub = undefined+
+ Views.hs view
@@ -0,0 +1,23 @@+module Views where++import Book++-- | File system entry.+data PathElement = LibDir String | LibFile Book | StubFile String+ deriving (Eq)++instance Show PathElement where+ show (LibDir dir) = dir+ show (LibFile book) = bookFileName book+ show (StubFile s) = s++-- | Type of directory view (what is its contents).+data View = Author | Title | Genre | Lang | AuthorInitial++instance Show View where+ show Author = "Author"+ show Title = "Title"+ show Genre = "Genre"+ show Lang = "Lang"+ show AuthorInitial = "AuthorInitial"+
+ mumrik.hs view
@@ -0,0 +1,233 @@+module Main where++import System.Fuse+import System.FilePath (splitPath, pathSeparator)+import System.Posix.Types (ByteCount, FileOffset)+import qualified Data.ByteString as B++-- assuming UTF8 encoding for filesystem, FIXME+import Codec.Binary.UTF8.String (encodeString, decodeString)+import Data.Maybe (fromMaybe)+import Control.Applicative ((<$>))+import Text.Regex.TDFA ((=~))++import Codec.Archive.LibZip++import System.Log.Logger+import System.Log.Handler.Syslog++import FileStats+import Book+import DB+import Views+import Utils++main :: IO ()+main = do+ let libraryFuseOps :: FuseOperations BookHandle+ libraryFuseOps = defaultFuseOps {+ fuseGetFileStat = getFileStat+ , fuseOpenDirectory = ok+ , fuseReadDirectory = readDir+ , fuseReleaseDirectory = ok+ , fuseOpen = openBookFile+ , fuseRead = readBookFile+ , fuseRelease = releaseBookFile+ , fuseInit = initLibrary+ , fuseGetFileSystemStats = fsStats+ }+ fuseMain libraryFuseOps defaultExceptionHandler++ok :: (Monad m) => a -> m Errno+ok = \_ -> return eOK -- FIXME: it's a stub++data BookHandle = BookHandle+ { zipfile :: Zip+ , filename :: FilePath }++-- | Defines available hierarchical ways to organize and access the library as+-- [ @[ (Top_level_directory, [ Type_of_the_next_subdirectory ] ) ]@.+-- The last view should be 'Title'.+accessPaths :: [ (FilePath, [View]) ]+accessPaths = [+ ( "author", [ AuthorInitial+ , Author+ , Title ] )+ , ( "genre", [ Genre+ , AuthorInitial+ , Author+ , Title ] )+ , ( "lang", [ Lang+ , AuthorInitial+ , Author+ , Title ] )+ ]++-- | Contents of the root directory of the filesystem.+topLevels :: [String]+topLevels = map fst accessPaths++-- fuse callbacks++-- Use large block size, because Zip-archives are not good to request ranges.+fsStats :: String -> IO (Either Errno FileSystemStats)+fsStats _ = retr $ FileSystemStats (4*1024*1024) 0 0 0 0 0 255++initLibrary :: IO ()+initLibrary = do+ -- initialize loggers+ s <- openlog "snusmumrik" [] DAEMON DEBUG+ updateGlobalLogger rootLoggerName (setLevel DEBUG . addHandler s)++getFileStat :: FilePath -> IO (Either Errno FileStat)+-- getFileStat _ fp | dbg ("getFileStat: " ++ (decodeString fp)) = stub+getFileStat "" = retl eFAULT -- bad path+getFileStat "/" = retr . snd =<< defaultStats -- root directory+getFileStat fp@('/':_) = do -- path should start with '/'+ let (top:choices) = pathToChoices fp -- FIXME: pattern match can fail+ let views = fromMaybe [] $ lookup top accessPaths+ let cvs = zip choices views+ -- ... if /author/p/Plato stats are requested, we have:+ -- choices = [ "p", "Plato" ]+ -- views = [ AuthorInitial , Author , ... ]+ -- => itemname = "Plato"+ -- itemview = Just Author+ let itemname = fromMaybe "" $ fst <$> (maybeLast cvs)+ if itemname =~ "^SqlError {.*}$"+ then retr . fst =<< defaultStats -- it's a stub file (error file)+ else+ let itemview = snd <$> (maybeLast cvs) in+ case itemview of+ Just Title -> do -- it's a book and we need to find its actual stats+ -- sequence of views should be unambiguous+ db' <- initDB+ catchSql ( do+ b <- maybeHead <$> findBooks db' choices views+ disconnect db'+ case b of+ Nothing -> retl eNOENT+ Just b' -> do+ (f,_) <- defaultStats+ retr $ bookStats f b'+ ) (\_ -> disconnect db' >> retl eIO )+ _ -> retr . snd =<< defaultStats -- anything else is a directory+getFileStat _ = retl eFAULT -- bad path++readDir :: FilePath -> IO (Either Errno [(FilePath, FileStat)])+readDir fp = readDir_ $ pathToChoices fp++readDir_ :: [FilePath] -> IO (Either Errno [(FilePath, FileStat)])+readDir_ fp | dbg ("readDir_: " ++ (showL' fp)) = stub+readDir_ fp = do+ stats <- defaultStats+ case fp of+ [] -> retr $ map (pathstats stats . LibDir) topLevels+ (toplevel:choices) ->+ let branch = lookup toplevel accessPaths+ in case branch of+ Nothing -> retl eNOENT -- top level not found+ Just views ->+ let next = drop (length $ zip choices views) $ views+ in case next of+ [] -> retl eFAULT -- bad path, not enough views defined+ _ -> do+ elements <- listNext choices views+ retr $ map (pathstats stats) elements+ where+ pathstats :: (FileStat, FileStat) -> PathElement -> (FilePath, FileStat)+ pathstats (_,d) (LibDir name) = encFst (name, d)+ pathstats (f,_) (LibFile book) = encFst (bookFileName book,bookStats f book)+ pathstats (_,d) (StubFile s) = encFst (s, d)+ encFst = withFst encodeString+ withFst f (a,b) = (f a,b)++openBookFile :: FilePath -> OpenMode -> OpenFileFlags+ -> IO (Either Errno BookHandle)+openBookFile fp _ _ | dbg ("openBookFile: " ++ (decodeString fp)) = stub+openBookFile "" _ _ = retl eFAULT -- bad path+openBookFile filepath ReadOnly flags | valid flags =+ catchZipError ( do+ let (top:choices) = pathToChoices filepath+ case lookup top accessPaths of+ Nothing -> retl eNOENT -- top level not found+ Just views -> do+ conn <- initDB+ catchSql ( do+ books <- findBooks conn choices views+ disconnect conn+ case books of+ [] -> retl eNOENT -- file not found+ [b] -> do+ z <- open (archive b) []+ retr $ BookHandle { zipfile=z, filename=path b }+ _ -> retl eINVAL -- more than one book found, invalid accessPaths?+ ) (\_ -> disconnect conn >> retl eIO)+ ) (\_ -> retl eIO )+ where+ valid f = not (append f || exclusive f || noctty f || nonBlock f || trunc f)+openBookFile _ _ _ = retl ePERM -- not read-only or not default flags++readBookFile :: FilePath -> BookHandle -> ByteCount -> FileOffset+ -> IO (Either Errno B.ByteString)+readBookFile fp _ bc off+ | dbg ("readBookFile: " ++ (decodeString fp) ++ " "+ ++ (show bc) ++ " from " ++ (show off)) = stub+readBookFile _ bh bc off = do+ let z = zipfile bh+ let fn = filename bh+ catchZipError ( do+ bytes <- readZipFile' z fn []+ let sz' = (fromIntegral bc)+ let off' = fromIntegral off+ let bytes' = take sz' . drop off' $ bytes+ retr . B.pack $ bytes'+ ) (\_ -> retl eIO)++releaseBookFile :: FilePath -> BookHandle -> IO ()+releaseBookFile fp _ | dbg ("releaseBookFile: " ++ (decodeString fp)) = stub+releaseBookFile _ bh = catchZipError ( do+ close (zipfile bh)+ ) (\_ -> return ()) -- FIXME++-- actual machinery++listNext :: [String] -- ^ choices made on previous steps (splitted path w/o toplevel)+ -> [View] -- ^ access path+ -> IO [PathElement]+listNext cs vs | dbg ("listNext: " ++ (showL' cs) ++" "++ (show vs)) = stub+listNext _ [] = return []+listNext choices views = do+ let n = length choices+ let next = maybeHead $ drop n views+ let findElems f elemType = do+ catchSql ( do+ conn <- initDB+ r <- (map elemType) <$> f conn choices views+ disconnect conn+ return r+ ) (\e -> do+ return $ [ StubFile (show e) ]+ )+ case next of+ Nothing -> return []+ Just AuthorInitial -> findElems findAuthorInitials LibDir+ Just Author -> findElems findAuthors LibDir+ Just Genre -> findElems findGenres LibDir+ Just Lang -> findElems findLangs LibDir+ Just Title -> findElems findBooks LibFile++-- helpers and shortcuts++-- pathToChoices of "/abc/def" is ["abc", "def"]+pathToChoices :: FilePath -> [String]+pathToChoices "" = []+pathToChoices [c] | c == pathSeparator = []+pathToChoices p = tail . map (filter (/= pathSeparator)) . splitPath . decodeString $ p++retl :: (Monad m) => a -> m (Either a b)+retl = return . Left++retr :: (Monad m) => b -> m (Either a b)+retr = return . Right++
+ snus.hs view
@@ -0,0 +1,48 @@+module Main where++import Control.Monad (forM_)+import System.Directory (canonicalizePath)+import System.Environment (getArgs)+import IO (stderr, hPutStrLn)++import qualified System.IO.UTF8 as U++import Codec.Archive.LibZip++import DB+import Book++-- title-info of the FB2 file is expected to be found within first 8 kbytes.+fbHeadSize :: Int+fbHeadSize = 8*1024++main :: IO ()+main = do+ db <- initDB+ args <- getArgs+ forM_ args $ \arg -> do+ catchZipError $ do+ zipfile <- canonicalizePath arg+ withZip zipfile [] $ \z -> do+ files <- getFiles z []+ forM_ files $ \file -> do+ -- TODO: implement lazy reading in LibZip+ txt <- readZipFileHead' z file [] fbHeadSize+ sz <- getFileSize z file []+ let info = let i = readBookInfo $ toString txt+ in i { archive = zipfile, path = file, size = sz }+ catchSql (insert file db info)+ $ \e -> putErr $ "DB error: " ++ file ++ ": " ++ (seErrorMsg e)+ $ \e -> putErr $ "Archive error: " ++ arg ++ ": " ++ (show e)+ where+ insert :: String -> Connection -> Book -> IO ()+ insert fname db info = do+ withTransaction db $ \db' -> insertBook db' info+ U.putStrLn $ fname ++ ":" ++ (concat $ take 2 $ lines $ show info)++putErr :: String -> IO ()+putErr msg = hPutStrLn stderr msg++toString :: [Word8] -> String+toString = map w2c+ where w2c = toEnum . fromEnum