augur-2008.10.19: src/Utils.hs

module Utils where

import Data.Char

import qualified Data.Map as M
import qualified Data.ByteString.Char8 as BS
import Numeric
import System.Process
import Text.XML.HaXml (xmlParse, Document)
import Data.Bits
import System.IO
import System.Exit
import Control.Monad.Trans
import Control.Monad

import Types
import Config

trunc :: String -> String
trunc cs = [ toLower c | c <- cs, isAlphaNum c ]

truncMinimal :: String -> String
truncMinimal = filter isAlphaNum

knownTags :: [TorrentTag]
knownTags = [minBound .. maxBound]

knownTagsMap :: M.Map String TorrentTag
knownTagsMap = M.fromList [ (map toLower (show tag), tag) | tag <- knownTags ]

extractTags :: String -> [TorrentTag]
extractTags str
    = let localTags = M.fromList [ (map toLower tag, ()) | tag <- splitWith isAlphaNum str ]
      in M.elems $ knownTagsMap `M.intersection` localTags

splitWith :: (a -> Bool) -> [a] -> [[a]]
splitWith _fn [] = []
splitWith fn lst
    = let (f,rest) = span fn lst
      in f:splitWith fn (dropWhile (not.fn) rest)


showSize :: Int -> String
showSize n'
    = loop sizes (fromIntegral n')
    where loop [] n = showFFloat (Just 0) (n::Float) " bytes"
          loop ((s,p):xs) n | n >= s = showFFloat (Just 2) (n/s) p
                            | otherwise = loop xs n
          sizes = [ (giga, " GiB")
                  , (mega, " MiB")
                  , (kilo, " KiB")]


kilo = 1024
mega = kilo*kilo
giga = mega*kilo

{-
getCurrentTime :: MonadIO m => m TimeStamp
getCurrentTime = liftIO $
    do TOD secs _ <- getClockTime
       return (fromIntegral secs)
-}

downloadToMem :: Config -> String -> IO BS.ByteString
downloadToMem cfg url
    = do when (confVerbose cfg >= 2) $ putStrLn $ "Downloading: " ++ url
         (_inh,outh,_errh,p) <- runInteractiveProcess (confWGetPath cfg)
                                ["--tries=3","-T","20","--quiet",url,"-O","-","-U","firefox"]
                                Nothing Nothing
         out <- BS.hGetContents outh
         waitForProcess p
         when (confVerbose cfg >= 2) $ putStrLn $ "Download finished: " ++ show (BS.length out) ++ "bytes"
         return out

mkGoogleUrl :: String -> String -> String
mkGoogleUrl site query
    = "http://www.google.com/search?hl=en&q=site%3A"++site++"+"++urlEncode query++"&btnI=I%27m+Feeling+Lucky"

htmlToXml :: Config -> BS.ByteString -> IO BS.ByteString
htmlToXml cfg html
    = do (inh, outh, _errh, p) <- runInteractiveProcess (confTidyPath cfg)
                                  ["-i","-asxml","-f","/dev/null"] Nothing Nothing
         BS.hPut inh html
         hFlush inh
         hClose inh
         out <- BS.hGetContents outh
         e <- waitForProcess p
         case e of
           ExitFailure 2 -> return ()
           _ -> return ()
         return out

downloadAsXML :: Config -> String -> IO Document
downloadAsXML cfg url
    = do html <- downloadToMem cfg url
         xml <- htmlToXml cfg html
         return $! xmlParse url (BS.unpack xml)

urlEncode :: String -> String
urlEncode (h:t) =
    let str = if reserved (ord h) then escape h else [h]
    in str ++ urlEncode t
    where
        reserved x
            | x >= ord 'a' && x <= ord 'z' = False
            | x >= ord 'A' && x <= ord 'Z' = False
            | x >= ord '0' && x <= ord '9' = False
            | x <= 0x20 || x >= 0x7F = True
            | otherwise = x `elem` map ord [';','/','?',':','@','&'
                                           ,'=','+',',','$','{','}'
                                           ,'|','\\','^','[',']','`'
                                           ,'<','>','#','%','"']
        -- wouldn't it be nice if the compiler
        -- optimised the above for us?

        escape x = 
            let y = ord x 
            in [ '%', intToDigit ((y `div` 16) .&. 0xf), intToDigit (y .&. 0xf) ]

urlEncode [] = []