Implement FZ download

src/Yore/Download.hs

@@ -1,21 +1,28 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
 
-module Yore.Download where
+module Yore.Download (downloadInto, getUrls) where
 
+import Control.Lens hiding ((<.>))
 import Control.Monad (guard)
 import Data.Char
-import Data.List (find)
-import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)
+import Data.Maybe (fromJust, fromMaybe, listToMaybe, mapMaybe, catMaybes)
 import Data.Text (Text)
 import Data.Time (Day, MonthOfYear, Year, fromGregorian, toGregorian)
-import Network.HTTP.Req
+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.List.NonEmpty as NonEmpty
+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
@@ -25,12 +32,36 @@ data TargetSpec = TargetSpec
   }
   deriving (Show)
 
-getUrl :: Day -> IO Text
-getUrl date = do
+-- | Download a URL and save it to a directory.
+-- Returns the path of the downloaded file relative to the directory.
+downloadInto
+  :: FilePath -- ^ Directory where to store the file.
+  -> Text -- ^ The URL to download.
+  -> IO FilePath
+downloadInto downloadDir textUrl = download >>= save
+  where
+    download :: IO LBS.ByteString
+    download = do
+      uri <- URI.mkURI textUrl
+      let (url, opts) = fromJust $ useHttpsURI uri
+      res <- runReq defaultHttpConfig $ req GET url NoReqBody lbsResponse opts
+      guard $ responseStatusCode res == 200
+      pure $ responseBody res
+
+    save :: LBS.ByteString -> IO FilePath
+    save contents = do
+      let suffix = takeExtension $ Text.unpack textUrl
+      uuid <- UUID.nextRandom
+      let fullPath = downloadDir </> show uuid <.> suffix
+      createDirectoryIfMissing True downloadDir
+      LBS.writeFile fullPath contents
+      pure $ makeRelative downloadDir fullPath
+
+getUrls :: Day -> IO [Text]
+getUrls date = do
   let (y, m, _) = toGregorian date
-  candidates <- getMonthOverview y m
-  let (_, ts) = fromMaybe (error "no candidates") $ find ((date ==) . fst) candidates
-  fromMaybe (error "could not get showpdf url") <$> getShowpdf ts
+  candidates <- filter ((date ==) . fst) <$> getMonthOverview y m
+  catMaybes <$> mapM (getShowpdf . snd) candidates
 
 getShowpdf :: TargetSpec -> IO (Maybe Text)
 getShowpdf (TargetSpec y m d) = do
@@ -59,12 +90,14 @@ getShowpdf (TargetSpec y m d) = do
       httpEquiv <- getAttr "http-equiv" attrs
       guard $ httpEquiv == "refresh"
       content <- getAttr "content" attrs
-      Just $ snd $ Text.breakOnEnd "URL=" content
+      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)]
 getMonthOverview year month = do
   res <- runReq defaultHttpConfig $ req
@@ -93,16 +126,16 @@ getMonthOverview year month = do
     extractDay uri =
       fromGregorian y m d
       where
-        y = read $ maybe "0" Text.unpack $ getParam "year" uri
-        m = read $ maybe "0" Text.unpack $ getParam "month" uri
-        d = read $ maybe "0" (takeWhile isDigit . Text.unpack) $ getParam "day" uri
+        y = read $ Text.unpack $ getParam [queryKey|year|] "0" uri
+        m = read $ Text.unpack $ getParam [queryKey|month|] "0" uri
+        d = read $ Text.unpack $ Text.takeWhile isDigit $ getParam [queryKey|day|] "0" uri
 
     extractTarget uri =
       TargetSpec y m d
       where
-        y = fromMaybe "" $ getParam "year" uri
-        m = fromMaybe "" $ getParam "month" uri
-        d = fromMaybe "" $ getParam "day" uri
+        y = fromMaybe "" (uri ^? uriQuery . queryParam [queryKey|year|] . unRText)
+        m = fromMaybe "" (uri ^? uriQuery . queryParam [queryKey|month|] . unRText)
+        d = fromMaybe "" (uri ^? uriQuery . queryParam [queryKey|day|] . unRText)
 
     decodeHtmlEntities = Text.pack . q0 . Text.unpack
       where
@@ -118,16 +151,14 @@ getMonthOverview year month = do
           -- Or if they end unexpectedly.
           | otherwise = c : q0 r
 
-    isShowpdf uri =
-      getPath uri == ["show", "fz.cgi"] && getParam "cmd" uri == Just "showpdf"
 
-getPath :: URI -> [Text]
-getPath uri = case URI.uriPath uri of
-  Nothing -> []
-  Just (_, rts) -> map URI.unRText $ NonEmpty.toList rts
-
-getParam :: Text -> URI ->  Maybe Text
-getParam param uri = listToMaybe [value | (key, value) <- map go (URI.uriQuery uri), key == param]
+isShowpdf :: URI -> Bool
+isShowpdf uri =
+  path == ["show", "fz.cgi"] && cmd == Just "showpdf"
   where
-    go (URI.QueryFlag k) = (URI.unRText k, "")
-    go (URI.QueryParam k v) = (URI.unRText k, URI.unRText v)
+    path = uri ^.. uriPath . each . unRText
+    cmd  = uri ^? uriQuery . queryParam [queryKey|cmd|] . unRText
+
+getParam :: URI.RText URI.QueryKey -> Text -> URI -> Text
+getParam param fallback uri =
+  fromMaybe fallback (uri ^? uriQuery . queryParam param . unRText)