module Webrexp.ResourcePath
( ResourcePath (..)
, rezPathToString
, downloadBinary
) where
import Webrexp.GraphWalker
import Control.Applicative
import Control.Monad.IO.Class
import Data.Maybe
import Network.HTTP
import Network.Browser
import Network.URI
import System.Directory
import System.FilePath
import qualified Webrexp.ProjectByteString as B
import Webrexp.Remote.MimeTypes
data ResourcePath =
Local FilePath
| Remote URI
deriving (Eq, Show)
instance GraphPath ResourcePath where
(<//>) = combinePath
importPath = toRezPath
dumpDataAtPath = dumpResourcePath
localizePath = extractFileName
rezPathToString :: ResourcePath -> String
rezPathToString (Local p) = p
rezPathToString (Remote uri) = show uri
toRezPath :: String -> Maybe ResourcePath
toRezPath s = case (parseURI s, isValid s, isRelativeReference s) of
(Just u, _, _) -> Just $ Remote u
(Nothing, True, _) -> Just $ Local s
(Nothing, False, True) -> Remote <$> parseRelativeReference s
(Nothing, False, False) -> Nothing
combinePath :: ResourcePath -> ResourcePath -> ResourcePath
combinePath (Local a) (Local b) = Local $ dropFileName a </> b
combinePath (Remote a) (Remote b) =
case b `relativeTo` a of
Nothing -> error "Can't merge resourcepath"
Just c -> Remote c
combinePath (Remote a) (Local b)
| isRelativeReference b = case parseRelativeReference b of
Just r -> Remote . fromJust $ r `relativeTo` a
Nothing -> error "Not possible, checked before"
combinePath (Local _) b@(Remote _) = b
combinePath _ _ = error "Mixing local/remote path"
extractFileName :: ResourcePath -> String
extractFileName (Remote a) = snd . splitFileName $ uriPath a
extractFileName (Local c) = snd $ splitFileName c
dumpResourcePath :: (Monad m, MonadIO m)
=> Loggers -> ResourcePath -> m ()
dumpResourcePath _ src@(Local source) = do
cwd <- liftIO getCurrentDirectory
liftIO . copyFile source $ cwd </> extractFileName src
dumpResourcePath loggers@(logger,_,_) p@(Remote a) = do
(_, rsp) <- downloadBinary loggers a
let rawFilename = extractFileName p
filename = case retrieveHeaders HdrContentType rsp of
[] -> rawFilename
(hdr:_) -> addContentTypeExtension
(hdrValue hdr) rawFilename
liftIO . logger $ "Downloading '" ++ show a ++ "' in '" ++ filename
liftIO . B.writeFile filename $ rspBody rsp
downloadBinary :: (Monad m, MonadIO m)
=> Loggers -> URI -> m (URI, Response B.ByteString)
downloadBinary (_, errLog, verbose) url =
liftIO . browse $ do
setAllowRedirects True
setErrHandler errLog
setOutHandler verbose
request $ defaultGETRequest_ url