Split up Download module
This commit is contained in:
+3
-151
@@ -1,38 +1,19 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Yore.Download (downloadInto, getUrls) where
|
||||
module Yore.Download (downloadInto) where
|
||||
|
||||
import Control.Lens hiding ((<.>))
|
||||
import Control.Monad (forM, guard)
|
||||
import Data.Char
|
||||
import Data.Maybe (fromJust, listToMaybe, mapMaybe, catMaybes)
|
||||
import Control.Monad (guard)
|
||||
import Data.Maybe (fromJust)
|
||||
import Data.Text (Text)
|
||||
import Data.Time (Day, MonthOfYear, Year, fromGregorian, toGregorian)
|
||||
import Network.HTTP.Req hiding (queryParam)
|
||||
import System.Directory (createDirectoryIfMissing)
|
||||
import System.FilePath (makeRelative, takeExtension, (</>), (<.>))
|
||||
import Text.HTML.Parser
|
||||
import Text.Printf (printf)
|
||||
import Text.URI (URI)
|
||||
import Text.URI.Lens
|
||||
import Text.URI.QQ hiding (uri)
|
||||
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.Encoding as Encoding
|
||||
import qualified Data.UUID.V4 as UUID
|
||||
import qualified Text.URI as URI
|
||||
|
||||
data TargetSpec = TargetSpec
|
||||
{ tsYear :: Text
|
||||
, tsMonth :: Text
|
||||
, tsDay :: Text
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
-- | Download a URL and save it to a directory.
|
||||
-- Returns the path of the downloaded file relative to the directory.
|
||||
downloadInto
|
||||
@@ -57,132 +38,3 @@ downloadInto downloadDir textUrl = download >>= save
|
||||
createDirectoryIfMissing True downloadDir
|
||||
LBS.writeFile fullPath contents
|
||||
pure $ makeRelative downloadDir fullPath
|
||||
|
||||
getUrls :: Day -> IO [(Text, Text)]
|
||||
getUrls date = do
|
||||
let (y, m, _) = toGregorian date
|
||||
allTargets <- getMonthOverview y m
|
||||
|
||||
let candidates = [t | t@(tDate, _, _) <- allTargets, tDate == date]
|
||||
mb <- forM candidates $ \(_, target, text) -> do
|
||||
mbUrl <- getShowpdf target
|
||||
case mbUrl of
|
||||
Nothing -> pure Nothing
|
||||
Just url -> pure $ Just (text, url)
|
||||
|
||||
pure $ catMaybes mb
|
||||
|
||||
getShowpdf :: TargetSpec -> IO (Maybe Text)
|
||||
getShowpdf (TargetSpec y m d) = do
|
||||
res <- runReq defaultHttpConfig $ req
|
||||
GET
|
||||
-- E.g. https://fz.ub.uni-freiburg.de/show/fz.cgi?cmd=showpdf&day=01r1&year=1925&month=07&project=3
|
||||
(https "fz.ub.uni-freiburg.de" /: "show" /: "fz.cgi")
|
||||
NoReqBody
|
||||
bsResponse
|
||||
(formToQuery
|
||||
[ ("cmd" :: Text, "showpdf")
|
||||
, ("year", y)
|
||||
, ("month", m)
|
||||
, ("day", d)
|
||||
])
|
||||
|
||||
guard $ responseStatusCode res == 200
|
||||
|
||||
let tokens = parseTokens $ Encoding.decodeUtf8Lenient $ responseBody res
|
||||
let targets = mapMaybe getRefreshTarget tokens
|
||||
|
||||
pure $ listToMaybe targets
|
||||
|
||||
where
|
||||
getRefreshTarget (TagOpen "meta" attrs) = do
|
||||
httpEquiv <- getAttr "http-equiv" attrs
|
||||
guard $ httpEquiv == "refresh"
|
||||
content <- getAttr "content" attrs
|
||||
Just $ escapeBrackets $ snd $ Text.breakOnEnd "URL=" content
|
||||
getRefreshTarget _ =
|
||||
Nothing
|
||||
|
||||
getAttr k = lookup k . map (\(Attr k' v) -> (k', v))
|
||||
|
||||
escapeBrackets = Text.replace "[" "%5B" . Text.replace "]" "%5D"
|
||||
|
||||
getMonthOverview :: Year -> MonthOfYear -> IO [(Day, TargetSpec, Text)]
|
||||
getMonthOverview year month = do
|
||||
res <- runReq defaultHttpConfig $ req
|
||||
GET
|
||||
(https "fz.ub.uni-freiburg.de" /: "show" /: "fz.cgi")
|
||||
NoReqBody
|
||||
bsResponse
|
||||
("cmd" =: ("showmonth" :: Text)
|
||||
<> "year" =: (printf "%04d" year :: String)
|
||||
<> "month" =: (printf "%02d" month :: String)
|
||||
-- TODO: What does this actually do?
|
||||
<> "project" =: ("3" :: Text))
|
||||
|
||||
guard $ responseStatusCode res == 200
|
||||
|
||||
let contents = Encoding.decodeUtf8Lenient $ responseBody res
|
||||
let tokens = parseTokens contents
|
||||
pure $ parseTargetSpecs tokens
|
||||
|
||||
parseTargetSpecs :: [Token] -> [(Day, TargetSpec, Text)]
|
||||
parseTargetSpecs = q0 []
|
||||
where
|
||||
q0 tss ((getShowDay -> Just uri) : ts) = q1 tss "" uri ts
|
||||
q0 tss (_ : ts) = q0 tss ts
|
||||
q0 tss [] = reverse tss
|
||||
|
||||
q1 tss text t (ContentText content : ts) = q1 tss (text <> content) t ts
|
||||
q1 tss text t (TagClose "a" : ts) = q0 ((extractDay t, t, text) : tss) ts
|
||||
q1 tss _ _ ts = q0 tss ts
|
||||
|
||||
getShowDay :: Token -> Maybe TargetSpec
|
||||
getShowDay t = do
|
||||
href <- getAHref t
|
||||
uri <- URI.mkURI $ decodeHexEntities href
|
||||
extractShowday uri
|
||||
|
||||
getAHref :: Token -> Maybe Text
|
||||
getAHref (TagOpen "a" attrs) = listToMaybe [href | Attr "href" href <- attrs]
|
||||
getAHref _ = Nothing
|
||||
|
||||
extractDay :: TargetSpec -> Day
|
||||
extractDay ts =
|
||||
fromGregorian y m d
|
||||
where
|
||||
y = read $ Text.unpack $ tsYear ts
|
||||
m = read $ Text.unpack $ tsMonth ts
|
||||
d = read $ Text.unpack $ Text.takeWhile isDigit $ tsDay ts
|
||||
|
||||
extractShowday :: URI -> Maybe TargetSpec
|
||||
extractShowday uri
|
||||
| path == ["show", "fz.cgi"] && cmd == Just "showday" = do
|
||||
y <- getParam [queryKey|year|] uri
|
||||
m <- getParam [queryKey|month|] uri
|
||||
d <- getParam [queryKey|day|] uri
|
||||
pure $ TargetSpec y m d
|
||||
| otherwise =
|
||||
Nothing
|
||||
where
|
||||
path = uri ^.. uriPath . each . unRText
|
||||
cmd = uri ^? uriQuery . queryParam [queryKey|cmd|] . unRText
|
||||
|
||||
getParam :: URI.RText URI.QueryKey -> URI -> Maybe Text
|
||||
getParam param uri =
|
||||
uri ^? uriQuery . queryParam param . unRText
|
||||
|
||||
decodeHexEntities :: Text -> Text
|
||||
decodeHexEntities = Text.pack . q0 . Text.unpack
|
||||
where
|
||||
q0 "" = ""
|
||||
q0 ('&' : '#' : r) = q1 0 r
|
||||
q0 (c : r) = c : q0 r
|
||||
|
||||
-- Silently swallows broken entities at the end of the string...
|
||||
q1 _ "" = ""
|
||||
q1 acc (';' : r) = chr acc : q0 r
|
||||
q1 acc (c : r)
|
||||
| isDigit c = q1 (10 * acc + ord c - ord '0') r
|
||||
-- Or if they end unexpectedly.
|
||||
| otherwise = c : q0 r
|
||||
|
||||
Reference in New Issue
Block a user