Add label to indexed files, implement rudimentary server

src/Yore/Download.hs

@@ -1,13 +1,14 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE QuasiQuotes #-}
 
 module Yore.Download (downloadInto, getUrls) where
 
 import Control.Lens hiding ((<.>))
-import Control.Monad (guard)
+import Control.Monad (forM, guard)
 import Data.Char
-import Data.Maybe (fromJust, fromMaybe, listToMaybe, mapMaybe, catMaybes)
+import Data.Maybe (fromJust, listToMaybe, mapMaybe, catMaybes)
 import Data.Text (Text)
 import Data.Time (Day, MonthOfYear, Year, fromGregorian, toGregorian)
 import Network.HTTP.Req hiding (queryParam)
@@ -57,11 +58,19 @@ downloadInto downloadDir textUrl = download >>= save
       LBS.writeFile fullPath contents
       pure $ makeRelative downloadDir fullPath
 
-getUrls :: Day -> IO [Text]
+getUrls :: Day -> IO [(Text, Text)]
 getUrls date = do
   let (y, m, _) = toGregorian date
-  candidates <- filter ((date ==) . fst) <$> getMonthOverview y m
-  catMaybes <$> mapM (getShowpdf . snd) candidates
+  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
@@ -98,7 +107,7 @@ getShowpdf (TargetSpec y m d) = do
 
     escapeBrackets = Text.replace "[" "%5B" . Text.replace "]" "%5D"
 
-getMonthOverview :: Year -> MonthOfYear -> IO [(Day, TargetSpec)]
+getMonthOverview :: Year -> MonthOfYear -> IO [(Day, TargetSpec, Text)]
 getMonthOverview year month = do
   res <- runReq defaultHttpConfig $ req
     GET
@@ -108,57 +117,72 @@ getMonthOverview year month = do
     ("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
-  let links = mapMaybe (fmap decodeHtmlEntities . getHref) tokens
-  uris <- mapM URI.mkURI links
-
-  pure [(extractDay uri, extractTarget uri) | uri <- uris, isShowpdf uri]
+  pure $ parseTargetSpecs tokens
 
+parseTargetSpecs :: [Token] -> [(Day, TargetSpec, Text)]
+parseTargetSpecs = q0 []
   where
-    getHref (TagOpen "a" attrs) = listToMaybe [href | Attr "href" href <- attrs]
-    getHref _ = Nothing
+    q0 tss ((getShowDay -> Just uri) : ts) = q1 tss "" uri ts
+    q0 tss (_ : ts) = q0 tss ts
+    q0 tss [] = reverse tss
 
-    extractDay uri =
-      fromGregorian y m d
-      where
-        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
+    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
 
-    extractTarget uri =
-      TargetSpec y m d
-      where
-        y = fromMaybe "" (uri ^? uriQuery . queryParam [queryKey|year|] . unRText)
-        m = fromMaybe "" (uri ^? uriQuery . queryParam [queryKey|month|] . unRText)
-        d = fromMaybe "" (uri ^? uriQuery . queryParam [queryKey|day|] . unRText)
+getShowDay :: Token -> Maybe TargetSpec
+getShowDay t = do
+  href <- getAHref t
+  uri <- URI.mkURI $ decodeHexEntities href
+  extractShowday uri
 
-    decodeHtmlEntities = Text.pack . q0 . Text.unpack
-      where
-        q0 "" = ""
-        q0 ('&' : '#' : r) = q1 0 r
-        q0 (c : r) = c : q0 r
+getAHref :: Token -> Maybe Text
+getAHref (TagOpen "a" attrs) = listToMaybe [href | Attr "href" href <- attrs]
+getAHref _ = Nothing
 
-        -- 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
+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
 
-
-isShowpdf :: URI -> Bool
-isShowpdf uri =
-  path == ["show", "fz.cgi"] && cmd == Just "showpdf"
+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 -> Text -> URI -> Text
-getParam param fallback uri =
-  fromMaybe fallback (uri ^? uriQuery . queryParam param . 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