src/Pompage.hs

   1 {-# LANGUAGE TypeSynonymInstances, OverlappingInstances, NoMonomorphismRestriction, ScopedTypeVariables #-}
   2
   3 import System.IO (readFile, FilePath(..))
   4 import System.Directory (
   5      getDirectoryContents
   6    , doesDirectoryExist
   7    )
   8 import System.FilePath ((</>))
   9 import System.Environment (getArgs, getProgName)
  10 import Data.List
  11 import Text.Printf (printf)
  12 import Text.XML.Light
  13 import qualified Text.XML.Light.Cursor as C
  14 import Control.Monad (foldM)
  15 import Control.Exception (SomeException(..), handle, bracket)
  16
  17 type Movies = [Movie]
  18
  19 data Movie = Movie {
  20      movieId :: Int
  21    , movieTitle :: String
  22    , movieYear :: Maybe Int
  23    , movieDirectors :: [String]
  24    , movieActors :: [String]
  25    , movieCountries :: [String]
  26    , movieLength :: Maybe Int
  27    , movieUserRating :: Maybe Int
  28    , moviePressRating :: Maybe Int
  29    , movieGenres :: [String]
  30    , movieSynopsis :: String
  31    , movieBudget :: Maybe Int
  32    , movieBudgetUnit :: String
  33    , movieFiles :: [FilePath]
  34    , movieUrl :: String
  35 } deriving (Show)
  36
  37 emptyMovie = Movie 0 "no title" Nothing [] [] []
  38    Nothing Nothing Nothing [] "" Nothing "" [] ""
  39
  40 data Arg = XML | MovieDir deriving (Show, Eq)
  41 type Args = [(Arg, String)]
  42
  43 main = do
  44    args <- getArgs
  45    progName <- getProgName
  46    case checkArgs $ readArgs args of
  47       Nothing -> printf usage progName
  48       Just args -> do
  49          let Just dir = lookup MovieDir args
  50          let Just xmlFile = lookup XML args
  51          paths <- moviePaths dir
  52          movies <- readXMLFile xmlFile
  53          print movies
  54          --print paths
  55
  56 coversDir = "../img/covers"
  57 movieExtenstions = ["avi", "mkv", "rmvb", "ogm", "divx"]
  58 usage = "Usage : %s -d <Movies dir> -x <XML file>\n"
  59
  60 checkArgs :: Maybe Args -> Maybe Args
  61 checkArgs Nothing = Nothing
  62 checkArgs (Just args) =
  63    case (lookup XML args, lookup MovieDir args) of
  64       (Just _, Just _) -> Just args
  65       otherwise -> Nothing
  66
  67 readArgs :: [String] -> Maybe Args
  68 readArgs (name:value:rest)
  69    | name == "-x" = (XML, value) <:> readArgs rest
  70    | name == "-d" = (MovieDir, value) <:> readArgs rest
  71    | otherwise = Nothing
  72    where
  73       _ <:> Nothing = Nothing
  74       arg <:> Just args = Just $ arg : args
  75 readArgs (_:[]) = Nothing
  76 readArgs (_) = Just []
  77
  78 moviePaths :: FilePath -> IO [FilePath]
  79 moviePaths dir = do
  80    paths <- filePaths (\filename ->
  81       any (`isSuffixOf` filename) movieExtenstions) dir
  82    -- Keep only the relative path.
  83    return $ map (drop $ Data.List.length dir + 1) paths
  84
  85 filePaths :: (String -> Bool) -> FilePath -> IO [FilePath]
  86 filePaths predicat baseDir = do
  87    processDir baseDir
  88    where
  89       processDir dir = do
  90          contents <- getDirectoryContents dir
  91          foldM (\acc entry -> do
  92             let absDir = dir </> entry
  93             doesDirectoryExist absDir >>= \exists ->
  94                if exists
  95                then do
  96                   paths <- processDir absDir
  97                   return (paths ++ acc)
  98                else
  99                   if predicat entry
 100                   then
 101                      return (absDir : acc)
 102                   else
 103                     return acc)
 104             []
 105             (contents \\ ["..", "."])
 106
 107 readXMLFile :: FilePath -> IO Movies
 108 readXMLFile file = do
 109    content <- readFile file
 110    let Just root = parseXMLDoc content
 111    return $
 112       foldl (\acc elem ->
 113          case elementXMLToMovie elem of
 114             Nothing -> acc
 115             Just movie -> movie : acc)
 116       []
 117       (elChildren root)
 118
 119
 120 type ParseState = C.Cursor
 121 newtype Parse alpha = Parse {
 122       runParse :: ParseState -> Either String (alpha, ParseState)
 123    }
 124 identity :: alpha -> Parse alpha
 125 identity a = Parse (\s -> Right (a, s))
 126
 127 parseNextSibilingContent :: Parse String
 128 parseNextSibilingContent =
 129    getState ==> \initState ->
 130       case nextSibilingElement initState of
 131          Nothing ->
 132             bail "no more sibiling slement"
 133          Just (elem, cursor) ->
 134             putState cursor ==> \_ ->
 135                identity (strContent elem)
 136
 137 getState :: Parse ParseState
 138 getState = Parse (\s -> Right (s, s))
 139
 140 -- Remplace the current state by a new one.
 141 putState :: ParseState -> Parse ()
 142 putState s = Parse (\_ -> Right ((), s))
 143
 144 -- Construct a parser which return a string error.
 145 bail :: String -> Parse alpha
 146 bail err = Parse $ \s ->
 147    Left $
 148       err ++ "\nFail at " ++
 149       case C.current s of
 150          Elem elem -> "element '" ++ qName (elName elem) ++ "'" ++ showLine (elLine elem)
 151          Text txt -> "text '" ++ cdData txt ++ "'" ++ showLine (cdLine txt)
 152          CRef cref -> "cref '" ++ cref
 153    where
 154       showLine line =
 155             case line of
 156                Just l -> " (line " ++ show l ++ ")"
 157                Nothing -> ""
 158
 159 (==>) :: Parse alpha -> (alpha -> Parse beta) -> Parse beta
 160 firstParser ==> secondParser = Parse chainedParser
 161    where
 162       chainedParser initState =
 163          case runParse firstParser initState of
 164             Left errMessage ->
 165                Left errMessage
 166             Right (firstResult, newState) ->
 167                runParse (secondParser firstResult) newState
 168
 169 elementXMLToMovie :: Element -> Maybe Movie
 170 elementXMLToMovie elem =
 171    Just (emptyMovie, C.fromElement elem) >>?
 172    (\(m, c) ->
 173       case C.current c of
 174          Elem elem ->
 175             case findAttr (simpleQName "id") elem of
 176             Nothing -> Nothing
 177             Just id -> Just (m { movieId = read id :: Int }, c)
 178          otherwise -> Nothing) >>?
 179    (\(m, c) ->
 180       case firstChildElement c of
 181          Just (elem, c') -> Just (m { movieTitle = strContent elem }, c')
 182          otherwise -> Nothing) >>?
 183    (\(m, c) ->
 184       case nextSibilingElement c of
 185          Just (elem, c') -> Just m { movieYear =  intElement elem }
 186          otherwise -> Nothing)
 187
 188 -- A bit naive
 189 (>>?) :: Maybe alpha -> (alpha -> Maybe beta) -> Maybe beta
 190 Nothing >>? _ = Nothing
 191 Just v >>? f = f v
 192
 193 -- Some XML helper functions
 194 simpleQName name = QName name Nothing Nothing
 195 firstChildElement :: C.Cursor -> Maybe (Element, C.Cursor)
 196 firstChildElement c =
 197    case C.firstChild c of
 198       Just c' ->
 199          case C.current c' of
 200             Elem elem -> Just (elem, c')
 201             otherwise -> nextSibilingElement c'
 202       otherwise -> Nothing
 203
 204 nextSibilingElement :: C.Cursor -> Maybe (Element, C.Cursor)
 205 nextSibilingElement c =
 206    case C.right c of
 207       Just c' ->
 208          case C.current c' of
 209             Elem elem -> Just (elem, c')
 210             otherwise -> nextSibilingElement c'
 211       Nothing -> Nothing
 212
 213 -- Try to cast an element content to an Int.
 214 intElement :: Element -> Maybe Int
 215 intElement elem =
 216    if content == []
 217       then Nothing
 218       else Just (read content :: Int)
 219    where content = strContent elem
 220
 221 writeXMLFile :: Movies -> FilePath -> IO ()
 222 writeXMLFile movies file = undefined
 223
 224 filesPath :: FilePath -> IO [FilePath]
 225 filesPath basePath = undefined
 226
 227 movieName :: FilePath -> String
 228 movieName = undefined
 229
 230 -- Int is the module id.
 231 data SearchResult = OK (Int, Movie)
 232  | Many [(Int, String)] -- String is the name of the movie.
 233  | NotFound
 234
 235 data Module = Module {
 236      search :: String -> IO SearchResult
 237    -- Int is the module id. FilePath is a path to the image like "../img/4353"
 238    , downloadImage :: Int -> FilePath
 239 }
 240
 241 {-
 242    Gets a movie by asking the given module to find a movie.
 243    A movie is seeked by its the filename.
 244    If there is many possibilities then it will ask the user.
 245 -}
 246 searchAMovie :: String -> Module -> IO SearchResult
 247 searchAMovie filename mod = undefined
 248
 249