Commits

Sergey Astanin committed d116dae

Epic remake: generated SQL instead of recursive views. Added /genre, /lang.

  • Participants
  • Parent commits 31a1e0e

Comments (0)

Files changed (6)

 import Data.ByteString.Lazy.Internal (smallChunkSize)
 import Data.List (intercalate)
 import System.FilePath (makeValid, takeBaseName)
-import Text.Regex.Posix ((=~))
+import Text.Regex.TDFA ((=~))
 
 import FB2
+import Utils
 
 -- TODO: consider structured author
 data Book = Book {
 bookFileName :: Book -> String
 bookFileName book =
   let t = title book
-      as = intercalate ", " $ authors book
-      fname = takeBaseName $ path 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
-  in makeValid $ intercalate " ~ " [ t, (as ++ year), (fname ++ ".fb2") ]
+      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 t
+                      in  unfixname t
 
 {-# LANGUAGE FlexibleContexts #-}
 module DB
   ( initDB, insertBook
-  , getAuthorsByInitial, getBooksByAuthor, findBooks
+  , findAuthorInitials, findAuthors, findGenres, findLangs, findBooks
   , Connection(), clone, commit, rollback, withTransaction, disconnect
   , catchSql, SqlError(..)) where
 
 import Control.Applicative ((<$>))
-import Data.Char (isUpper, toUpper, toLower)
-import Data.List (sort, nub, foldl', intercalate, intersperse)
-import Data.Maybe (fromJust, isJust, maybeToList)
+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
         bookGenres :: [[SqlValue]]
         bookGenres = map (\g -> bookLoc ++ [g]) genreNames
 
-getAuthorsByInitial :: Connection -> Char -> IO [String]
-getAuthorsByInitial _ i | dbg ("getAuthorsByInitial: " ++ [i]) = stub
-getAuthorsByInitial db initial = do
-  let query = "select name from authors \
-              \ where name like ? \
-              \    or name like ? \
-              \ order by name"
-  rows <- quickQuery' db query $ map (toSql . (:"%") ) [initial', initial]
-  -- just first columns (not so sure if there are no empty rows)
-  return . map fromSql . column 0 $ rows
-  where initial' | isUpper initial = toLower initial
-                 | otherwise       = toUpper initial
+-- | 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)) (trace' params) :: IO [[SqlValue]]
+  let inis = onlyJusts . map fromSql . column 0 $ rows
+  return . map (:[]) . nub . map (replaceX . toLower) . concatMap head' $ inis
+  where
+  replaceX c | (toLower c) `notElem` romanOrCyrillic = '_'
+             | otherwise                             = c
+  head' :: [a] -> [a]
+  head' [] = []
+  head' (x:_) = [x]
 
--- | Find all books with given author name.
-getBooksByAuthor :: Connection -> String -> IO [Book]
-getBooksByAuthor db author = findBooks db [author] [Author blind]
+-- 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.
-findBooks :: Connection -> [String] -> [Selector] -> IO [Book]
+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 qbegin = "select distinct b.id, b.title, b.lang, b.date,\
-              \ b.archive, b.path, b.size"
-  let qend   = "order by b.title"
-  let fws = foldl' (liftT2 (++)) (["books b"],[],[])
-            $ map fromWhere $ zip choices views
-  let q :: String
-      q =   intercalate " " $ [qbegin]
-                           ++ ("from":(intersperse "," (nub $ fst3 fws)))
-                           ++ ("where":(intersperse "and" (snd3 fws)))
-                           ++ [qend]
-  rows <- quickQuery' db q $ map toSql $ trd3 fws :: IO [[SqlValue]]
-  let books = concatMap maybeToList $ map toBook rows :: [(Int,Book)]
+  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
-    -- produce ([tables],[conditions],[positional_params])
-    fromWhere :: (String,Selector) -> ([String],[String],[String])
-    fromWhere (c, Author _) = (["authors a","bookauthors ba"]
-                              , ["b.id = ba.book_id"
-                                ,"ba.author_id = a.id"
-                                ,"a.name = ?"]
-                              ,[c])
-    fromWhere (c, Genre _) = (["genres g", "bookgenres bg"]
-                             , ["b.id = bg.book_id"
-                               ,"bg.genre_id = g.id"
-                               ,"g.genre = ?"]
-                               ,[c])
-    fromWhere (c, Title _) = ([], ["b.title = ?"], [titleFromFileName c])
-    fromWhere _            = ([], [], [])
+  -- 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
 toBook _ = Nothing
 
 onlyJusts :: [Maybe a] -> [a]
-onlyJusts = foldl (\ acc n -> if isJust n then (fromJust n):acc else acc) []
+onlyJusts = concatMap maybeToList
 
 column :: Int -> [[a]] -> [a]
 column n xss = onlyJusts $ map (maybeNth n) xss
 
 import Codec.Binary.UTF8.String (encodeString)
 import Data.List (intercalate)
+import Data.Maybe (fromMaybe)
 import Debug.Trace (trace)
 
+-- | 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 DEBUG
 dbg msg = trace (encodeString msg) False
 dbg _ = False
 #endif
 
+-- | Debug tracing.
 trace' :: (Show a) => a -> a
 #ifdef DEBUG
 trace' x = trace (show x) x
 module Views where
 
-import Control.Concurrent.STM (TVar)
-import Database.HDBC.Sqlite3 (Connection)
-import System.Fuse (Errno)
-
 import Book
 
 -- | File system entry.
   show (LibFile book) = bookFileName book
   show (StubFile s)   = s
 
--- | Functions which define what is the contents of a virtual directory
-type View = TVar Connection -- ^ open DB connection to use
-         -> [FilePath] -- ^ list of the previous choices (splitted path)
-         -> IO (Either Errno [PathElement])
+-- | Type of directory view (what is its contents).
+data View = Author | Title | Genre | Lang | AuthorInitial
 
--- | 'View' with a type tag.
-data Selector = Author View | Title View | Genre View | AuthorInitial View
+instance Show View where
+  show Author = "Author"
+  show Title = "Title"
+  show Genre = "Genre"
+  show Lang = "Lang"
+  show AuthorInitial = "AuthorInitial"
 
--- | Remove type tags from 'Selector's.
-view :: Selector -> View
-view (Author v) = v
-view (Title v) = v
-view (Genre v) = v
-view (AuthorInitial v) = v
-
--- | Trivial view of nothing.
-blind :: View
-blind _ _ = return $ Right []
 module Main where
 
 import System.Fuse
-import System.FilePath
+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.List (intercalate)
 import Data.Maybe (fromMaybe)
 import Control.Applicative ((<$>))
 import Control.Concurrent.STM
+import Text.Regex.TDFA ((=~))
 
 import Codec.Archive.LibZip
 
                   , filename :: FilePath }
 
 -- | Defines available hierarchical ways to organize and access the library as
--- [ @[ (Top_level_directory, [ Function_to_view_the_next_subdirectory ] ) ]@.
--- The last selector should be 'Title' 'View'.
-accessPaths :: [ (FilePath, [Selector]) ]
+-- [ @[ (Top_level_directory, [ Type_of_the_next_subdirectory ] ) ]@.
+-- The last view should be 'Title'.
+accessPaths :: [ (FilePath, [View]) ]
 accessPaths = [
-    ( "author", [ AuthorInitial initials
-                , Author authorsByInitial
-                , Title booksByAuthor ] )
+    ( "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
 
--- TODO: list authors with other initials (greek letters etc.)
--- TODO: hide initials for which there are no nested elements
-initials :: View
-initials _ _ = retr . map LibDir . map (:[]) $ ['a'..'z'] ++ ['а'..'я']
-
-authorsByInitial :: View
-authorsByInitial _ choices | dbg ("authorsByInitial: " ++ (showL' choices)) = stub
-authorsByInitial _ [] = retl eINVAL
-authorsByInitial db choices = do
-      let prev = last choices
-      if length prev /= 1
-        then retl eINVAL -- parent directory should be one-letter
-        else do
-          db' <- getConn db
-          catchSql ( do
-              authors' <- getAuthorsByInitial db' (head prev)
-              retr $ map LibDir authors'
-            ) (\e -> do
-              retr $ [(StubFile (show e))]
-            )
-
-booksByAuthor :: View
-booksByAuthor _ choices | dbg ("booksByAuthor: " ++ (showL' choices)) = stub
-booksByAuthor _ [] = retl eINVAL
-booksByAuthor db choices = do
-  let author = last choices
-  db' <- getConn db
-  catchSql ( do
-      books <- getBooksByAuthor db' author
-      retr $ map LibFile books
-    ) (\e -> do
-      retr $ [(StubFile (show e))]
-    )
-
 -- fuse callbacks
 
 getFileStat :: TVar Connection -> FilePath -> IO (Either Errno FileStat)
-getFileStat _ fp | dbg ("getFileStat: " ++ (decodeString fp)) = stub
+-- getFileStat _ fp | dbg ("getFileStat: " ++ (decodeString fp)) = stub
 getFileStat _ "" = retl eFAULT -- bad path
 getFileStat _ "/" = retr . snd =<< defaultStats -- root directory
-getFileStat db ('/':rfp) = do  -- path should start with '/'
-  let (top:choices) = map (filter (/= '/')) . splitPath . decodeString $ rfp
+getFileStat db 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
-  -- e.g. if /author/p/Plato stats are requested, we have:
-  -- views: [ AuthorInitial initials, Author authorsByInitial, ... ]
-  -- choices: [ "p", "Plato" ]
-  -- => fileview: Just (Author authorsByInitial)
-  let fileview = snd <$> (maybeLast cvs)
-  case fileview of
-    Just (Title _) -> do -- it's a book and we need to find its actual stats
+  -- ... 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' <- getConn db
-      b <- maybeHead <$> findBooks db' choices views
-      case b of
-        Nothing -> retl eNOENT
-        Just b' -> do
-          (f,_) <- defaultStats
-          retr $ bookStats f b'
-    _ -> retr . snd =<< defaultStats -- anything else is a directory
+          db' <- getConn db
+          catchSql ( do
+              b <- maybeHead <$> findBooks db' choices views
+              case b of
+                Nothing -> retl eNOENT
+                Just b' -> do
+                  (f,_) <- defaultStats
+                  retr $ bookStats f b'
+            ) (\_ -> retl eIO )
+        _ -> retr . snd =<< defaultStats -- anything else is a directory
 getFileStat _ _ = retl eFAULT -- bad path
 
 readDir :: TVar Connection -> FilePath -> IO (Either Errno [(FilePath, FileStat)])
-readDir db fp = readDir_ db $ splitPath $ decodeString fp
+readDir db fp = readDir_ db $ pathToChoices fp
 
 readDir_ :: TVar Connection -> [FilePath] -> IO (Either Errno [(FilePath, FileStat)])
-readDir_ _ fp | dbg ("readDir: " ++ (showL' fp)) = stub
+readDir_ _ fp | dbg ("readDir_: " ++ (showL' fp)) = stub
 readDir_ db fp = do
-  (f,d) <- defaultStats
-  r <- listNextStep db fp
-  case r of
-    Left e -> retl e
-    Right pelms -> retr . map (withFst encodeString . pathstats (f,d)) $ pelms
+  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 db choices views
+                    retr $ map (pathstats stats) elements
   where
     pathstats :: (FileStat, FileStat) -> PathElement -> (FilePath, FileStat)
-    pathstats (_,d) (LibDir name) = (name, d)
-    pathstats (f,_) (LibFile book) = (bookFileName book, bookStats f book)
-    pathstats (_,d) (StubFile s) = (s, d)
+    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 :: TVar Connection -> FilePath -> OpenMode -> OpenFileFlags
 openBookFile _ "" _ _ = retl eFAULT -- bad path
 openBookFile db filepath ReadOnly flags | valid flags =
   catchZipError ( do
-      let parent = init $ splitPath $ decodeString filepath
-      let fname = takeFileName $ decodeString filepath
-      r <- listNextStep db parent :: IO (Either Errno [PathElement]) -- parent dir
-      case r of
-        Left e -> retl e
-        Right pelms -> do
-          let namesake = maybeHead . filter (\e -> (show e) == fname) $ pelms
-          case namesake of
-            Nothing -> retl eNOENT -- file not found
-            Just (LibDir _) -> retl eISDIR
-            Just (StubFile _) -> retl ePERM
-            Just (LibFile b) -> do
-              z <- open (archive b) []
-              retr $ BookHandle { zipfile=z, filename=path b }
+      let (top:choices) = pathToChoices filepath
+      case lookup top accessPaths of
+        Nothing -> retl eNOENT -- top level not found
+        Just views -> do
+          conn <- getConn db
+          catchSql ( do
+            books <- findBooks conn choices views
+            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?
+           ) (\_ -> retl eIO)
     ) (\_  -> retl eIO )
   where
   valid f = not (append f || exclusive f || noctty f || nonBlock f || trunc f)
 
 -- actual machinery
 
-listNextStep :: TVar Connection
-             -> [ FilePath ] -- ^ list of the previous steps (splitted path)
-             -> IO (Either Errno [PathElement]) -- ^ choices for the next step
-listNextStep _ fp | dbg ("listNextStep: " ++ (showL' fp)) = stub
-listNextStep _ [] = retl eFAULT -- bad path
-listNextStep db (root:ss)
-  | root /= "/" = retl eFAULT -- bad path
-  | otherwise   =
-     -- ss' are unicode path elements without trailing '/'
-     let ss' = map (filter (/= '/')) ss
-     in case ss' of
-        [] -> retr $ map LibDir topLevels
-        (toplevel:steps) ->
-          let branch = lookup toplevel accessPaths
-           in case branch of
-              Nothing -> retl eNOENT      -- requested top level not found
-              Just p  -> listPath db [toplevel] p steps
-
-listPath :: TVar Connection -> [FilePath] -> [Selector] -> [FilePath]
-         -> IO (Either Errno [PathElement])
-listPath _ choices _ steps
-  | dbg ("listPath: " ++ (intercalate "; "
-        [ (showL "choices" choices) ,  (showL "steps" steps) ])) = stub
-listPath _ _ [] _  = retl e2BIG -- path too long, not enough views
-listPath db choices (topView:_) [] = view topView db choices  -- done
-listPath db choices (topView:views) (step:steps) = do
-    r <- view topView db choices
-    case r of
-      Left e -> retl e
-      Right pelms ->
-        if (LibDir step) `elem` pelms
-          then listPath db (choices ++ [step]) views steps
-          else retl eNOENT
+listNext :: TVar Connection
+         -> [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 db choices views = do
+  let n = length choices
+  let next = maybeHead $ drop n views
+  let findElems f elemType = do
+                        catchSql ( do
+                            conn <- getConn db
+                            return . map elemType =<< f conn choices views
+                          ) (\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
 
 getConn :: TVar Connection -> IO Connection
 getConn db = do
   master <- stmRead db
-  clone master
+  clone master -- FIXME: is a race condition here?
 
 

File snusmumrik.cabal

                , bytestring
                , utf8-string
                , iconv
-               , regex-posix
+               , regex-tdfa
                , HDBC
                , HDBC-sqlite3
                , convertible
-               , LibZip >= 0.0.2
+               , LibZip >= 0.0.2 && < 0.1
                , xml
 
   if flag(debug)
                , bytestring
                , utf8-string
                , iconv
-               , regex-posix
+               , regex-tdfa
                , HDBC
                , HDBC-sqlite3
                , convertible
                , stm
-               , LibZip >= 0.0.2
+               , LibZip >= 0.0.2 && < 0.1
                , unix
                , HFuse >= 0.2.1