diff --git a/Book.hs b/Book.hs new file mode 100644 --- /dev/null +++ b/Book.hs @@ -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 + diff --git a/DB.hs b/DB.hs new file mode 100644 --- /dev/null +++ b/DB.hs @@ -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 diff --git a/FB2.hs b/FB2.hs new file mode 100644 --- /dev/null +++ b/FB2.hs @@ -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 diff --git a/FileStats.hs b/FileStats.hs new file mode 100644 --- /dev/null +++ b/FileStats.hs @@ -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) } + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -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 diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/Snusmumrik.cabal b/Snusmumrik.cabal new file mode 100644 --- /dev/null +++ b/Snusmumrik.cabal @@ -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 + +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 + diff --git a/TODO b/TODO new file mode 100644 --- /dev/null +++ b/TODO @@ -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 diff --git a/Utils.hs b/Utils.hs new file mode 100644 --- /dev/null +++ b/Utils.hs @@ -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 + diff --git a/Views.hs b/Views.hs new file mode 100644 --- /dev/null +++ b/Views.hs @@ -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" + diff --git a/mumrik.hs b/mumrik.hs new file mode 100644 --- /dev/null +++ b/mumrik.hs @@ -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 + + diff --git a/snus.hs b/snus.hs new file mode 100644 --- /dev/null +++ b/snus.hs @@ -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