Semantique 0.2.2 → 0.3.0
raw patch · 2 files changed
+48/−11 lines, 2 files
Files
- Semantique.cabal +1/−1
- src/Main.hs +47/−10
Semantique.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: Semantique-version: 0.2.2+version: 0.3.0 synopsis: Command-line tool for maintaining the Semantique database. description: Command-line tool for maintaining the Semantique database. See <http://semantik.tv/> license: PublicDomain
src/Main.hs view
@@ -16,9 +16,14 @@ import Data.Maybe import Data.List (isPrefixOf,nub) import Data.Char+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BC8 import qualified Data.Text as T+import qualified Data.Text.Encoding as T import qualified Data.Map as Map import Control.Monad+import Control.Exception (evaluate)+import Prelude import Data.Classify.Television @@ -34,6 +39,7 @@ [port, "add", name] -> withMeteor addr port (addTVShow name) [port, "remove", name] -> withMeteor addr port (removeTVShow name) [port, "epguides", name] -> withMeteor addr port (mkEpguidesEntries name)+ [port, "epguides_all"] -> withMeteor addr port (mkAllEpguidesEntries) [port, "set_epguides", name, url] -> withMeteor addr port (setEpguides name url) [port, "rebuild"] -> withMeteor addr port rebuild@@ -41,7 +47,7 @@ withMeteor addr port fn = do pipe <- runIOE $ connect (Host addr (PortNumber (fromIntegral (read port :: Integer))))- access pipe master "meteor" fn+ access pipe slaveOk "meteor" fn close pipe @@ -54,7 +60,8 @@ hPutStrLn stderr $ printf " shows List the recognized TV shows." hPutStrLn stderr $ printf " add <name> Add a name to the list of known TV shows." hPutStrLn stderr $ printf " remove <name> Remove a name to the list of known TV shows."- hPutStrLn stderr $ printf " epguides <name> Fetch titles and air-times from stdin."+ hPutStrLn stderr $ printf " epguides <name> Fetch titles and air-times from epguides."+ hPutStrLn stderr $ printf " epguides_all Fetch titles and air-times from epguides." hPutStrLn stderr $ printf " set_epguides <name> <url> Associate <url> with <name>." hPutStrLn stderr $ printf " rebuild Recalculate computed properties in the DB." exitWith ExitSuccess@@ -79,7 +86,9 @@ addTVShow name = insert "meta" ["name" =: name] -setEpguides name url =+setEpguides name url = do+ shows <- getTVShows+ unless (name `elem` shows) $ error $ "Unknown TV series: " ++ name modify (select ["name" =: name] "meta") ["$set" =: ["epguides" =: url]] getEpguidesURL name = do@@ -133,6 +142,20 @@ modify (select ["_id" =: record_id] "episodes") ["$pull" =: ["instances" =: inst]] insertMagnetLinks shows [uri] +mkAllEpguidesEntries = do+ shows <- getTVShows+ mapM_ mkEpguidesEntries shows++hGetContentsSafe :: Handle -> IO String+hGetContentsSafe handle = do+ inp <- BS.hGetContents handle+ case T.decodeUtf8' inp of+ Right txt -> return $ T.unpack txt+ Left err -> do+ putStrLn $ "Failed to decode as UTF8: " ++ show err+ return $ BC8.unpack inp++ {- {name: TV show ,searchable: string@@ -145,25 +168,39 @@ mkEpguidesEntries name = do shows <- getTVShows unless (name `elem` shows) $ error $ "Unknown TV series: " ++ name+ liftIO $ putStrLn $ "Fetching meta information for show: " ++ name epguides_url <- getEpguidesURL name (inh, outh, errh, pid) <- liftIO $ runInteractiveProcess "wget" ["-q", "-O", "-", epguides_url] Nothing Nothing liftIO $ hClose inh >> hClose errh- inp <- liftIO $ hGetContents outh+ inp <- liftIO $ hGetContentsSafe outh+ liftIO $ evaluate (length inp) _ <- liftIO $ waitForProcess pid++ db <- rest =<< find (select ["name" =: name] "episodes") { project = ["episode" =: True, "title" =: True] }+ let dbAssoc =+ catMaybes+ [ do idx <- DB.lookup "episode" x+ title <- DB.lookup "title" x+ return (idx, title)+ | x <- db ]+ forM_ (parseEpguide inp) $ \(EpIdx season episode, (year, month, day), title) -> do- let query = ["name" =: name, "episode" =: ["season" =: season, "episode" =: episode ]]+ let query = ["name" =: name, "episode" =: idx ]+ idx = ["season" =: season, "episode" =: episode ] airdate = ["year" =: year, "month" =: month, "day" =: day]- n <- count (select query "episodes")- case n of- 0 -> do+ case Prelude.lookup idx dbAssoc of+ Nothing -> do liftIO $ putStrLn $ "Inserting new: " ++ show (season, episode, year, month, day, title) insert_ "episodes" [ "name" =: name , "episode" =: ["season" =: season, "episode" =: episode] , "airdate" =: airdate , "title" =: title ]- _ -> do- liftIO $ putStrLn $ "Updating: " ++ show (season, episode, year, month, day, title)+ Just oldTitle | oldTitle == title ->+ --liftIO $ putStrLn $ "Skipping: " ++ show (season, episode, year, month, day, title)+ return ()+ Just oldTitle -> do+ liftIO $ putStrLn $ "Updating: " ++ show (season, episode, year, month, day, oldTitle, title) modify (select query "episodes") ["$set" =: ["title" =: title, "airdate" =: airdate]]