From 554dce8a831082d6c8111f0b3d4833e3d715e815 Mon Sep 17 00:00:00 2001 From: vrom911 Date: Sun, 13 Aug 2017 02:44:37 +0300 Subject: [PATCH 1/9] [#124] Add links' date of the latest capture at archive.org --- src/Guide/Views.hs | 95 +++++++++++++++++++++++++++++++++++++--------- 1 file changed, 77 insertions(+), 18 deletions(-) diff --git a/src/Guide/Views.hs b/src/Guide/Views.hs index 71cf35e..574d1a1 100644 --- a/src/Guide/Views.hs +++ b/src/Guide/Views.hs @@ -1,7 +1,8 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE OverloadedStrings #-} +-- {-# LANGUAGE DuplicateRecordFields #-} {- | @@ -40,6 +41,7 @@ import Data.Monoid ((<>)) -- Text import qualified Data.Text.All as T import NeatInterpolation +import Data.ByteString.Lazy (toStrict) -- Web import Lucid hiding (for_) -- Network @@ -806,7 +808,7 @@ on those
s. -- things could be displayed in gray font and also there'd be an -- automatically updated list of TODOs somewhere?) -data LinkStatus = OK | Unparseable | Broken String deriving Show +data LinkStatus = OK | Unparseable | Broken String deriving Show -- | Render links page with info about broken links renderAdminLinks :: (MonadIO m) => GlobalState -> HtmlT m () @@ -838,28 +840,40 @@ renderAdminLinks globalState = do ) `catch` (return . handleHttpException) else pure Unparseable - pure (toHtml location, a_ [href_ lnk] (toHtml lnk), resp) + archDate <- getArchieveOrgLatestDate manager lnk + pure (toHtml location, a_ [href_ lnk] (toHtml lnk), resp, toHtml archDate) let (ok, unparseable, broken) = sortLinks fullList - - h2_ "Broken Links" + -- archiveAnswer <- liftIO $ do + -- requestArch <- parseRequest "http://archive.org/wayback/available?url=example.com" + -- respArch <- responseBody <$> httpLbs requestArch manager + -- -- let respBr = singleton (BS.c2w '[') <> resp <> singleton (BS.c2w ']') + -- d <- (A.eitherDecode <$> (pure respArch)) :: IO (Either String ArchiveOrgResponse) + -- case d of + -- Left err -> putStrLn err + -- Right ps -> print $ timestamp $ closest $ archivedSnapshots ps + -- pure respArch + -- + -- div_ $ toHtml $ toStrict archiveAnswer table_ [class_ "sortable"] $ do thead_ $ tr_ $ do th_ [class_ "sorttable_nosort"] "Category" th_ [class_ "sorttable_nosort"] "Link" th_ "Status" - tbody_ $ do - for_ broken $ \(location, lnk, reason) -> do + th_ "Latest archieve date" + tbody_ $ + for_ broken $ \(location, lnk, reason, d) -> tr_ $ do td_ location td_ lnk td_ $ toHtml reason + td_ d h2_ "Unparseable Links" table_ [class_ "sortable"] $ do thead_ $ tr_ $ do th_ [class_ "sorttable_nosort"] "Category" th_ [class_ "sorttable_nosort"] "Link" - tbody_ $ do - for_ unparseable $ \(cat, l) -> do + tbody_ $ + for_ unparseable $ \(cat, l) -> tr_ $ do td_ cat td_ l @@ -868,26 +882,37 @@ renderAdminLinks globalState = do thead_ $ tr_ $ do th_ [class_ "sorttable_nosort"] "Category" th_ [class_ "sorttable_nosort"] "Link" - tbody_ $ do - for_ ok $ \(cat, l) -> do + th_ [class_ "sorttable_nosort"] "Latest archieve date" + tbody_ $ + for_ ok $ \(cat, l, d) -> tr_ $ do td_ cat td_ l + td_ d where handleHttpException :: HttpException -> LinkStatus handleHttpException (HttpExceptionRequest _ x) = Broken $ show x handleHttpException (InvalidUrlException _ x) = Broken x - sortLinks :: [(a, b, LinkStatus)] -> ([(a, b)], [(a, b)], [(a, b, String)]) + sortLinks :: [(a, b, LinkStatus, c)] -> ([(a, b, c)], [(a, b)], [(a, b, String, c)]) sortLinks = foldr sortLink ([], [], []) - sortLink (a, b, OK) = (\(x, y, z) -> ((a, b):x, y, z)) - sortLink (a, b, Unparseable) = (\(x, y, z) -> (x, (a, b):y, z)) - sortLink (a, b, Broken text') = (\(x, y, z) -> (x, y, (a, b, text'):z)) + sortLink (a, b, OK, c) = \ (x, y, z) -> ((a, b, c) : x, y, z) + sortLink (a, b, Unparseable, _) = \ (x, y, z) -> (x, (a, b) : y, z) + sortLink (a, b, Broken text', c) = \ (x, y, z) -> (x, y, (a, b, text', c) : z) allLinks :: [(Url, Text)] allLinks = ordNub (findLinks globalState) + getArchieveOrgLatestDate manager lnk = do + requestArch <- parseRequest $ "http://archive.org/wayback/available?url="+|lnk|+"" + respArch <- responseBody <$> httpLbs requestArch manager + d <- (A.decode <$> pure respArch) :: IO (Maybe ArchiveOrgResponse) + let archDate = case d of + Just arch -> timestamp $ closest $ archivedSnapshots arch + Nothing -> "none" + pure archDate + -- | Find all links in content, along with a human-readable description of -- where each link is located. findLinks :: GlobalState -> [(Url, Text)] @@ -913,3 +938,37 @@ findLinksItem item = findLinksMD item' ++ maybeToList (item^.link) -- | Find all Markdown links in /any/ structure, using generics. findLinksMD :: Data a => a -> [Url] findLinksMD a = [url | MD.LINK url _ <- universeBi a] + +data ArchiveOrgResponse = + ArchiveOrgResponse { url :: String + , archivedSnapshots :: ArchivedSnapshot + } deriving (Show, Generic) + +data ArchivedSnapshot = + ArchivedSnapshot { closest :: Closest } deriving (Show, Generic) + +data Closest = + Closest { status' :: String + , available :: Bool + , url' :: String + , timestamp :: String + } deriving (Show, Generic) + +instance A.FromJSON ArchiveOrgResponse where + parseJSON (A.Object v) = + ArchiveOrgResponse <$> v A..: "url" + <*> v A..: "archived_snapshots" + parseJSON _ = mzero + +instance A.FromJSON ArchivedSnapshot where + parseJSON (A.Object v) = + ArchivedSnapshot <$> v A..: "closest" + parseJSON _ = mzero + +instance A.FromJSON Closest where + parseJSON (A.Object v) = + Closest <$> v A..: "status" + <*> v A..: "available" + <*> v A..: "url" + <*> v A..: "timestamp" + parseJSON _ = mzero From fee7a6d1bd6af9b4bb2c6ef4ea0c2686d1b9f682 Mon Sep 17 00:00:00 2001 From: vrom911 Date: Mon, 14 Aug 2017 20:07:56 +0300 Subject: [PATCH 2/9] [#124] Add button 'Save to Archive.org' --- src/Guide/JS.hs | 15 ++++++++-- src/Guide/Views.hs | 74 +++++++++++++++++++++++++--------------------- 2 files changed, 54 insertions(+), 35 deletions(-) diff --git a/src/Guide/JS.hs b/src/Guide/JS.hs index 6873128..d447d37 100644 --- a/src/Guide/JS.hs +++ b/src/Guide/JS.hs @@ -58,7 +58,8 @@ allJSFunctions = JS . T.unlines . map fromJS $ [ -- Admin things acceptEdit, undoEdit, acceptBlock, undoBlock, - createCheckpoint ] + createCheckpoint, + saveToArchiveOrg] -- | A class for things that can be converted to Javascript syntax. class ToJS a where toJS :: a -> JS @@ -677,6 +678,17 @@ createCheckpoint = }); |] +saveToArchiveOrg :: JSFunction a => a +saveToArchiveOrg = + makeJSFunction "saveToArchiveOrg" ["link"] + [text| + console.log(link); + $.post('http://web.archive.org/save/' + link) + .done(function () { + console.log("inside work's done") + }); + console.log("Job's done"); + |] -- When adding a function, don't forget to add it to 'allJSFunctions'! escapeJSString :: Text -> Text @@ -726,4 +738,3 @@ selectChildren a b = JQuerySelector $ format "{} > {}" a b selectSection :: JQuerySelector -> Text -> JQuerySelector selectSection a b = JQuerySelector $ format "{} > .section.{}" a b - diff --git a/src/Guide/Views.hs b/src/Guide/Views.hs index 574d1a1..06de185 100644 --- a/src/Guide/Views.hs +++ b/src/Guide/Views.hs @@ -41,7 +41,6 @@ import Data.Monoid ((<>)) -- Text import qualified Data.Text.All as T import NeatInterpolation -import Data.ByteString.Lazy (toStrict) -- Web import Lucid hiding (for_) -- Network @@ -840,60 +839,69 @@ renderAdminLinks globalState = do ) `catch` (return . handleHttpException) else pure Unparseable - archDate <- getArchieveOrgLatestDate manager lnk - pure (toHtml location, a_ [href_ lnk] (toHtml lnk), resp, toHtml archDate) + (archDate, archUrl) <- liftIO $ getArchieveOrgData manager lnk + pure ( toHtml location + , lnk + , resp + , (toHtml archDate, a_ [href_ (T.pack archUrl)] (toHtml $ show archUrl)) + ) let (ok, unparseable, broken) = sortLinks fullList -- archiveAnswer <- liftIO $ do -- requestArch <- parseRequest "http://archive.org/wayback/available?url=example.com" -- respArch <- responseBody <$> httpLbs requestArch manager - -- -- let respBr = singleton (BS.c2w '[') <> resp <> singleton (BS.c2w ']') -- d <- (A.eitherDecode <$> (pure respArch)) :: IO (Either String ArchiveOrgResponse) -- case d of -- Left err -> putStrLn err - -- Right ps -> print $ timestamp $ closest $ archivedSnapshots ps + -- Right ps -> print $ toProperDate $ timestamp $ closest $ archivedSnapshots ps -- pure respArch -- -- div_ $ toHtml $ toStrict archiveAnswer + -- div_ $ button "To Archive" [] (JS.saveToArchiveOrg [JS.toJS $ T.pack "example.com"]) table_ [class_ "sortable"] $ do thead_ $ tr_ $ do th_ [class_ "sorttable_nosort"] "Category" th_ [class_ "sorttable_nosort"] "Link" th_ "Status" - th_ "Latest archieve date" + th_ "Saved page" tbody_ $ - for_ broken $ \(location, lnk, reason, d) -> + for_ broken $ \(location, lnk, reason, (_, archUrl)) -> tr_ $ do td_ location - td_ lnk + td_ $ a_ [href_ lnk] (toHtml lnk) td_ $ toHtml reason - td_ d + td_ archUrl h2_ "Unparseable Links" table_ [class_ "sortable"] $ do thead_ $ tr_ $ do th_ [class_ "sorttable_nosort"] "Category" th_ [class_ "sorttable_nosort"] "Link" tbody_ $ - for_ unparseable $ \(cat, l) -> + for_ unparseable $ \(location, lnk) -> tr_ $ do - td_ cat - td_ l + td_ location + td_ $ a_ [href_ lnk] (toHtml lnk) h2_ "OK Links" table_ [class_ "sortable"] $ do thead_ $ tr_ $ do th_ [class_ "sorttable_nosort"] "Category" th_ [class_ "sorttable_nosort"] "Link" th_ [class_ "sorttable_nosort"] "Latest archieve date" + th_ "Save to Archive" tbody_ $ - for_ ok $ \(cat, l, d) -> + for_ ok $ \(location, lnk, (dt, _)) -> tr_ $ do - td_ cat - td_ l - td_ d + td_ location + td_ $ a_ [href_ lnk] (toHtml lnk) + td_ dt + td_ $ button "To Archive" [] (JS.saveToArchiveOrg [JS.toJS lnk]) where handleHttpException :: HttpException -> LinkStatus handleHttpException (HttpExceptionRequest _ x) = Broken $ show x handleHttpException (InvalidUrlException _ x) = Broken x + handleHttpExceptionDecode :: HttpException -> IO (String, String) + handleHttpExceptionDecode _ = pure ("error", "error") + sortLinks :: [(a, b, LinkStatus, c)] -> ([(a, b, c)], [(a, b)], [(a, b, String, c)]) sortLinks = foldr sortLink ([], [], []) @@ -904,14 +912,16 @@ renderAdminLinks globalState = do allLinks :: [(Url, Text)] allLinks = ordNub (findLinks globalState) - getArchieveOrgLatestDate manager lnk = do + getArchieveOrgData manager lnk = (do requestArch <- parseRequest $ "http://archive.org/wayback/available?url="+|lnk|+"" respArch <- responseBody <$> httpLbs requestArch manager d <- (A.decode <$> pure respArch) :: IO (Maybe ArchiveOrgResponse) - let archDate = case d of - Just arch -> timestamp $ closest $ archivedSnapshots arch - Nothing -> "none" - pure archDate + let archRes = case d of + Just arch -> ( show $ toProperDate $ timestamp $ closest $ archivedSnapshots arch + , url' $ closest $ archivedSnapshots arch + ) + Nothing -> ("none", "none") + pure archRes) `catch` handleHttpExceptionDecode -- | Find all links in content, along with a human-readable description of -- where each link is located. @@ -940,24 +950,21 @@ findLinksMD :: Data a => a -> [Url] findLinksMD a = [url | MD.LINK url _ <- universeBi a] data ArchiveOrgResponse = - ArchiveOrgResponse { url :: String - , archivedSnapshots :: ArchivedSnapshot + ArchiveOrgResponse { archivedSnapshots :: ArchivedSnapshot } deriving (Show, Generic) data ArchivedSnapshot = - ArchivedSnapshot { closest :: Closest } deriving (Show, Generic) + ArchivedSnapshot { closest :: Closest + } deriving (Show, Generic) -data Closest = - Closest { status' :: String - , available :: Bool - , url' :: String +data Closest = + Closest { url' :: String , timestamp :: String } deriving (Show, Generic) instance A.FromJSON ArchiveOrgResponse where parseJSON (A.Object v) = - ArchiveOrgResponse <$> v A..: "url" - <*> v A..: "archived_snapshots" + ArchiveOrgResponse <$> v A..: "archived_snapshots" parseJSON _ = mzero instance A.FromJSON ArchivedSnapshot where @@ -967,8 +974,9 @@ instance A.FromJSON ArchivedSnapshot where instance A.FromJSON Closest where parseJSON (A.Object v) = - Closest <$> v A..: "status" - <*> v A..: "available" - <*> v A..: "url" + Closest <$> v A..: "url" <*> v A..: "timestamp" parseJSON _ = mzero + +toProperDate :: String -> UTCTime +toProperDate = parseTimeOrError True defaultTimeLocale "%Y%m%d%H%M%S" From ae026a84703332a763a82717c19dc0d649fcad89 Mon Sep 17 00:00:00 2001 From: vrom911 Date: Sat, 19 Aug 2017 14:28:06 +0300 Subject: [PATCH 3/9] [#124] Replace tuples with data types in admin/links --- .gitignore | 2 + src/Guide/JS.hs | 4 +- src/Guide/Views.hs | 113 +++++++++++++++++++++++---------------------- 3 files changed, 62 insertions(+), 57 deletions(-) diff --git a/.gitignore b/.gitignore index ef9c384..0c8a953 100644 --- a/.gitignore +++ b/.gitignore @@ -20,6 +20,8 @@ cabal.config TAGS .DS_Store *~ +*.swp +*.swo *# state/ config.json diff --git a/src/Guide/JS.hs b/src/Guide/JS.hs index d447d37..28a70a6 100644 --- a/src/Guide/JS.hs +++ b/src/Guide/JS.hs @@ -682,12 +682,10 @@ saveToArchiveOrg :: JSFunction a => a saveToArchiveOrg = makeJSFunction "saveToArchiveOrg" ["link"] [text| - console.log(link); $.post('http://web.archive.org/save/' + link) .done(function () { - console.log("inside work's done") + console.log(link + " saved to archive.org") }); - console.log("Job's done"); |] -- When adding a function, don't forget to add it to 'allJSFunctions'! diff --git a/src/Guide/Views.hs b/src/Guide/Views.hs index 06de185..5f41b5c 100644 --- a/src/Guide/Views.hs +++ b/src/Guide/Views.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE OverloadedStrings #-} --- {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE ScopedTypeVariables #-} {- | @@ -807,10 +808,16 @@ on those
s. -- things could be displayed in gray font and also there'd be an -- automatically updated list of TODOs somewhere?) -data LinkStatus = OK | Unparseable | Broken String deriving Show +data LinkStatus = OK | Unparseable | Broken String deriving Show + +data LinkLocation m = LinkLocation { location :: HtmlT m () + , linkUrl :: Url + } + +data LinkInfo m = LinkInfo (LinkLocation m) LinkStatus (HtmlT m ()) (HtmlT m ()) -- | Render links page with info about broken links -renderAdminLinks :: (MonadIO m) => GlobalState -> HtmlT m () +renderAdminLinks :: forall m . (MonadIO m) => GlobalState -> HtmlT m () renderAdminLinks globalState = do head_ $ do includeJS "/js.js" @@ -839,24 +846,13 @@ renderAdminLinks globalState = do ) `catch` (return . handleHttpException) else pure Unparseable - (archDate, archUrl) <- liftIO $ getArchieveOrgData manager lnk - pure ( toHtml location - , lnk - , resp - , (toHtml archDate, a_ [href_ (T.pack archUrl)] (toHtml $ show archUrl)) - ) + (archDate, archUrl) <- liftIO $ getArchiveOrgData manager lnk + pure $ + LinkInfo (LinkLocation (toHtml location) lnk) + resp + archDate + archUrl let (ok, unparseable, broken) = sortLinks fullList - -- archiveAnswer <- liftIO $ do - -- requestArch <- parseRequest "http://archive.org/wayback/available?url=example.com" - -- respArch <- responseBody <$> httpLbs requestArch manager - -- d <- (A.eitherDecode <$> (pure respArch)) :: IO (Either String ArchiveOrgResponse) - -- case d of - -- Left err -> putStrLn err - -- Right ps -> print $ toProperDate $ timestamp $ closest $ archivedSnapshots ps - -- pure respArch - -- - -- div_ $ toHtml $ toStrict archiveAnswer - -- div_ $ button "To Archive" [] (JS.saveToArchiveOrg [JS.toJS $ T.pack "example.com"]) table_ [class_ "sortable"] $ do thead_ $ tr_ $ do th_ [class_ "sorttable_nosort"] "Category" @@ -864,10 +860,10 @@ renderAdminLinks globalState = do th_ "Status" th_ "Saved page" tbody_ $ - for_ broken $ \(location, lnk, reason, (_, archUrl)) -> + for_ broken $ \(LinkLocation{..}, reason, archUrl) -> tr_ $ do td_ location - td_ $ a_ [href_ lnk] (toHtml lnk) + td_ $ a_ [href_ linkUrl] (toHtml linkUrl) td_ $ toHtml reason td_ archUrl h2_ "Unparseable Links" @@ -876,51 +872,60 @@ renderAdminLinks globalState = do th_ [class_ "sorttable_nosort"] "Category" th_ [class_ "sorttable_nosort"] "Link" tbody_ $ - for_ unparseable $ \(location, lnk) -> + for_ unparseable $ \LinkLocation{..} -> tr_ $ do td_ location - td_ $ a_ [href_ lnk] (toHtml lnk) + td_ $ a_ [href_ linkUrl] (toHtml linkUrl) h2_ "OK Links" table_ [class_ "sortable"] $ do thead_ $ tr_ $ do th_ [class_ "sorttable_nosort"] "Category" th_ [class_ "sorttable_nosort"] "Link" - th_ [class_ "sorttable_nosort"] "Latest archieve date" + th_ [class_ "sorttable_nosort"] "Latest archiving date" th_ "Save to Archive" tbody_ $ - for_ ok $ \(location, lnk, (dt, _)) -> + for_ ok $ \(LinkLocation{..}, dt) -> tr_ $ do td_ location - td_ $ a_ [href_ lnk] (toHtml lnk) + td_ $ a_ [href_ linkUrl] (toHtml linkUrl) td_ dt - td_ $ button "To Archive" [] (JS.saveToArchiveOrg [JS.toJS lnk]) + td_ $ button "To Archive" [] (JS.saveToArchiveOrg [JS.toJS linkUrl]) where handleHttpException :: HttpException -> LinkStatus handleHttpException (HttpExceptionRequest _ x) = Broken $ show x handleHttpException (InvalidUrlException _ x) = Broken x - handleHttpExceptionDecode :: HttpException -> IO (String, String) - handleHttpExceptionDecode _ = pure ("error", "error") + handleHttpExceptionDecode :: HttpException -> IO (HtmlT m (), HtmlT m ()) + handleHttpExceptionDecode _ = + pure ("can't get latest archiving date", "can't get saved page link") - sortLinks :: [(a, b, LinkStatus, c)] -> ([(a, b, c)], [(a, b)], [(a, b, String, c)]) + sortLinks :: [LinkInfo m] + -> ( [(LinkLocation m, HtmlT m ())] + , [LinkLocation m] + , [(LinkLocation m, String, HtmlT m ())] + ) sortLinks = foldr sortLink ([], [], []) - sortLink (a, b, OK, c) = \ (x, y, z) -> ((a, b, c) : x, y, z) - sortLink (a, b, Unparseable, _) = \ (x, y, z) -> (x, (a, b) : y, z) - sortLink (a, b, Broken text', c) = \ (x, y, z) -> (x, y, (a, b, text', c) : z) + sortLink (LinkInfo a OK b _) = \ (x, y, z) -> ((a, b) : x, y, z) + sortLink (LinkInfo a Unparseable _ _) = \ (x, y, z) -> (x, a : y, z) + sortLink (LinkInfo a (Broken text') _ b) = \ (x, y, z) -> (x, y, (a, text', b) : z) allLinks :: [(Url, Text)] allLinks = ordNub (findLinks globalState) - getArchieveOrgData manager lnk = (do + getArchiveOrgData :: Manager -> Url -> IO (HtmlT m (), HtmlT m ()) + getArchiveOrgData manager lnk = (do requestArch <- parseRequest $ "http://archive.org/wayback/available?url="+|lnk|+"" - respArch <- responseBody <$> httpLbs requestArch manager - d <- (A.decode <$> pure respArch) :: IO (Maybe ArchiveOrgResponse) - let archRes = case d of - Just arch -> ( show $ toProperDate $ timestamp $ closest $ archivedSnapshots arch - , url' $ closest $ archivedSnapshots arch - ) - Nothing -> ("none", "none") + respArch <- responseBody <$> httpLbs requestArch manager + let d = A.decode respArch :: Maybe ArchiveOrgResponse + let archRes = + case d of + Just arch -> do + let archUrl = url' $ closest $ archivedSnapshots arch + let archDate = show $ timestamp $ closest $ archivedSnapshots arch + let linkUrl = a_ [href_ (T.pack archUrl)] (toHtml $ show archUrl) + ( toHtml archDate, linkUrl ) + Nothing -> ("none", "none") pure archRes) `catch` handleHttpExceptionDecode -- | Find all links in content, along with a human-readable description of @@ -949,6 +954,8 @@ findLinksItem item = findLinksMD item' ++ maybeToList (item^.link) findLinksMD :: Data a => a -> [Url] findLinksMD a = [url | MD.LINK url _ <- universeBi a] +-- TODO: get rid of complicated data structures +-- can be done when JSON parser is added data ArchiveOrgResponse = ArchiveOrgResponse { archivedSnapshots :: ArchivedSnapshot } deriving (Show, Generic) @@ -959,7 +966,7 @@ data ArchivedSnapshot = data Closest = Closest { url' :: String - , timestamp :: String + , timestamp :: UTCTime } deriving (Show, Generic) instance A.FromJSON ArchiveOrgResponse where @@ -973,10 +980,8 @@ instance A.FromJSON ArchivedSnapshot where parseJSON _ = mzero instance A.FromJSON Closest where - parseJSON (A.Object v) = - Closest <$> v A..: "url" - <*> v A..: "timestamp" - parseJSON _ = mzero - -toProperDate :: String -> UTCTime -toProperDate = parseTimeOrError True defaultTimeLocale "%Y%m%d%H%M%S" + parseJSON = A.withObject "Closest" $ \o -> do + url' <- o A..: "url" + timestamp <- o A..: "timestamp" >>= + parseTimeM True defaultTimeLocale "%Y%m%d%H%M%S" + pure Closest{..} From 1e19a6a9484557122ac5cbba69e274ce473dfd87 Mon Sep 17 00:00:00 2001 From: Artyom Date: Sun, 20 Aug 2017 01:53:28 +0300 Subject: [PATCH 4/9] Add JSON utils --- src/Guide/Utils.hs | 62 ++++++++++++++++++++++++++++++++++++++++ src/Guide/Views/Utils.hs | 6 ++-- 2 files changed, 64 insertions(+), 4 deletions(-) diff --git a/src/Guide/Utils.hs b/src/Guide/Utils.hs index df69be2..ef0afeb 100644 --- a/src/Guide/Utils.hs +++ b/src/Guide/Utils.hs @@ -46,6 +46,12 @@ module Guide.Utils randomLongUid, uid_, + -- * JSON + fromJson, + fromJsonWith, + toJson, + toJsonPretty, + -- * Lucid includeJS, includeCSS, @@ -76,8 +82,14 @@ import qualified Data.Set as S import System.Random -- Text import qualified Data.Text.All as T +-- Bytestring +import qualified Data.ByteString.Lazy as BSL -- JSON import qualified Data.Aeson as A +import qualified Data.Aeson.Text as A +import qualified Data.Aeson.Types as A +import qualified Data.Aeson.Internal as A +import qualified Data.Aeson.Encode.Pretty as A -- Network import qualified Network.Socket as Network import Data.IP @@ -360,6 +372,56 @@ data Node uid_ :: Uid Node -> Attribute uid_ = id_ . uidToText +---------------------------------------------------------------------------- +-- JSON +---------------------------------------------------------------------------- + +class AsJson s where + -- | Parse JSON using the default JSON instance. + fromJson :: A.FromJSON a => s -> Either String a + fromJson = fromJsonWith A.parseJSON + + -- | Parse JSON using a custom parser. + fromJsonWith :: (A.Value -> A.Parser a) -> s -> Either String a + fromJsonWith p s = do + v <- fromJson s + case A.iparse p v of + A.IError path err -> Left (A.formatError path err) + A.ISuccess res -> Right res + + -- | Convert a value to JSON. + toJson :: A.ToJSON a => a -> s + + -- | Convert a value to pretty-printed JSON. + toJsonPretty :: A.ToJSON a => a -> s + +instance AsJson ByteString where + fromJson = A.eitherDecodeStrict + toJson = BSL.toStrict . A.encode + toJsonPretty = BSL.toStrict . A.encodePretty + +instance AsJson LByteString where + fromJson = A.eitherDecode + toJson = A.encode + toJsonPretty = A.encodePretty + +instance AsJson Text where + fromJson = A.eitherDecode . T.toLByteString + toJson = T.toStrict . A.encodeToLazyText + toJsonPretty = T.toStrict . A.encodePrettyToTextBuilder + +instance AsJson LText where + fromJson = A.eitherDecode . T.toLByteString + toJson = A.encodeToLazyText + toJsonPretty = T.toLazy . A.encodePrettyToTextBuilder + +instance AsJson A.Value where + fromJsonWith p v = case A.iparse p v of + A.IError path err -> Left (A.formatError path err) + A.ISuccess res -> Right res + toJson = A.toJSON + toJsonPretty = A.toJSON + ---------------------------------------------------------------------------- -- Lucid ---------------------------------------------------------------------------- diff --git a/src/Guide/Views/Utils.hs b/src/Guide/Views/Utils.hs index 77a0ac3..64e52b7 100644 --- a/src/Guide/Views/Utils.hs +++ b/src/Guide/Views/Utils.hs @@ -87,7 +87,6 @@ import qualified System.FilePath.Find as F import Text.Mustache.Plus import qualified Data.Aeson as A import qualified Data.Aeson.Text as A -import qualified Data.Aeson.Encode.Pretty as A import qualified Data.ByteString.Lazy.Char8 as BS import qualified Data.Semigroup as Semigroup import qualified Data.List.NonEmpty as NonEmpty @@ -296,10 +295,9 @@ mustache f v = do ("selectIf", \[x] -> if x == A.Bool True then return (A.String "selected") else return A.Null), - ("js", \[x] -> return $ - A.String . T.toStrict . A.encodeToLazyText $ x), + ("js", \[x] -> return $ A.String (toJson x)), ("trace", \xs -> do - mapM_ (BS.putStrLn . A.encodePretty) xs + mapM_ (BS.putStrLn . toJsonPretty) xs return A.Null) ] widgets <- readWidgets let templates = [(tname, t) | (HTML_ tname, t) <- widgets] From fe01b1be38f01101fe81101dc1d9a1e6549e67c1 Mon Sep 17 00:00:00 2001 From: Artyom Date: Sun, 20 Aug 2017 16:47:48 +0300 Subject: [PATCH 5/9] [#124] Refactor --- src/Guide/Views.hs | 222 ++++++++++++++++++++------------------- src/Guide/Views/Utils.hs | 1 - 2 files changed, 113 insertions(+), 110 deletions(-) diff --git a/src/Guide/Views.hs b/src/Guide/Views.hs index 5f41b5c..e6bfdfb 100644 --- a/src/Guide/Views.hs +++ b/src/Guide/Views.hs @@ -810,11 +810,17 @@ on those
s. data LinkStatus = OK | Unparseable | Broken String deriving Show -data LinkLocation m = LinkLocation { location :: HtmlT m () - , linkUrl :: Url - } - -data LinkInfo m = LinkInfo (LinkLocation m) LinkStatus (HtmlT m ()) (HtmlT m ()) +data LinkInfo = LinkInfo { + -- | Link itself + linkUrl :: Url, + -- | A description of where the link is in Guide + linkLocation :: Text, + -- | Link status (ok, unparseable, etc) + linkStatus :: LinkStatus, + -- | Link status on archive.org (if archive.org is available) + linkArchivalStatus :: Either String ArchivalStatus + } + deriving (Show) -- | Render links page with info about broken links renderAdminLinks :: forall m . (MonadIO m) => GlobalState -> HtmlT m () @@ -836,7 +842,7 @@ renderAdminLinks globalState = do div_ [id_ "stats"] $ do manager <- liftIO $ newManager tlsManagerSettings fullList <- liftIO $ forM allLinks $ \(lnk, location) -> do - resp <- if isURI (T.unpack lnk) then (do + lnkStatus <- if isURI (T.unpack lnk) then (do request <- parseRequest $ T.unpack lnk status' <- responseStatus <$> httpNoBody request manager print (lnk, status') @@ -846,87 +852,92 @@ renderAdminLinks globalState = do ) `catch` (return . handleHttpException) else pure Unparseable - (archDate, archUrl) <- liftIO $ getArchiveOrgData manager lnk - pure $ - LinkInfo (LinkLocation (toHtml location) lnk) - resp - archDate - archUrl - let (ok, unparseable, broken) = sortLinks fullList - table_ [class_ "sortable"] $ do - thead_ $ tr_ $ do - th_ [class_ "sorttable_nosort"] "Category" - th_ [class_ "sorttable_nosort"] "Link" - th_ "Status" - th_ "Saved page" - tbody_ $ - for_ broken $ \(LinkLocation{..}, reason, archUrl) -> - tr_ $ do - td_ location - td_ $ a_ [href_ linkUrl] (toHtml linkUrl) - td_ $ toHtml reason - td_ archUrl - h2_ "Unparseable Links" - table_ [class_ "sortable"] $ do - thead_ $ tr_ $ do - th_ [class_ "sorttable_nosort"] "Category" - th_ [class_ "sorttable_nosort"] "Link" - tbody_ $ - for_ unparseable $ \LinkLocation{..} -> - tr_ $ do - td_ location - td_ $ a_ [href_ linkUrl] (toHtml linkUrl) - h2_ "OK Links" - table_ [class_ "sortable"] $ do - thead_ $ tr_ $ do - th_ [class_ "sorttable_nosort"] "Category" - th_ [class_ "sorttable_nosort"] "Link" - th_ [class_ "sorttable_nosort"] "Latest archiving date" - th_ "Save to Archive" - tbody_ $ - for_ ok $ \(LinkLocation{..}, dt) -> - tr_ $ do - td_ location - td_ $ a_ [href_ linkUrl] (toHtml linkUrl) - td_ dt - td_ $ button "To Archive" [] (JS.saveToArchiveOrg [JS.toJS linkUrl]) + archStatus <- liftIO (getArchivalStatus manager lnk) + pure $ LinkInfo { + linkUrl = lnk, + linkLocation = location, + linkStatus = lnkStatus, + linkArchivalStatus = archStatus } + renderUnparseableLinks fullList + renderBrokenLinks fullList + renderOKLinks fullList where handleHttpException :: HttpException -> LinkStatus handleHttpException (HttpExceptionRequest _ x) = Broken $ show x handleHttpException (InvalidUrlException _ x) = Broken x - handleHttpExceptionDecode :: HttpException -> IO (HtmlT m (), HtmlT m ()) - handleHttpExceptionDecode _ = - pure ("can't get latest archiving date", "can't get saved page link") - - sortLinks :: [LinkInfo m] - -> ( [(LinkLocation m, HtmlT m ())] - , [LinkLocation m] - , [(LinkLocation m, String, HtmlT m ())] - ) - sortLinks = foldr sortLink ([], [], []) - - sortLink (LinkInfo a OK b _) = \ (x, y, z) -> ((a, b) : x, y, z) - sortLink (LinkInfo a Unparseable _ _) = \ (x, y, z) -> (x, a : y, z) - sortLink (LinkInfo a (Broken text') _ b) = \ (x, y, z) -> (x, y, (a, text', b) : z) - + -- Link + a text description of where that link was found in Guide allLinks :: [(Url, Text)] allLinks = ordNub (findLinks globalState) - getArchiveOrgData :: Manager -> Url -> IO (HtmlT m (), HtmlT m ()) - getArchiveOrgData manager lnk = (do - requestArch <- parseRequest $ "http://archive.org/wayback/available?url="+|lnk|+"" - respArch <- responseBody <$> httpLbs requestArch manager - let d = A.decode respArch :: Maybe ArchiveOrgResponse - let archRes = - case d of - Just arch -> do - let archUrl = url' $ closest $ archivedSnapshots arch - let archDate = show $ timestamp $ closest $ archivedSnapshots arch - let linkUrl = a_ [href_ (T.pack archUrl)] (toHtml $ show archUrl) - ( toHtml archDate, linkUrl ) - Nothing -> ("none", "none") - pure archRes) `catch` handleHttpExceptionDecode +renderOKLinks :: Monad m => [LinkInfo] -> HtmlT m () +renderOKLinks links = do + h2_ "OK Links" + table_ [class_ "sortable"] $ do + thead_ $ tr_ $ + mapM_ th_ ["Location", "Link", "Archival status", "Save to archive.org"] + tbody_ $ + for_ (filterOK links) $ \LinkInfo{..} -> + tr_ $ do + td_ $ toHtml linkLocation + td_ $ a_ [href_ linkUrl] (toHtml linkUrl) + td_ $ renderArchivalStatus linkArchivalStatus + td_ $ button "archive" [] (JS.saveToArchiveOrg [JS.toJS linkUrl]) + where + filterOK xs = [x | x <- xs, OK <- [linkStatus x]] + +renderUnparseableLinks :: Monad m => [LinkInfo] -> HtmlT m () +renderUnparseableLinks links = do + h2_ "Unparseable Links" + table_ [class_ "sortable"] $ do + thead_ $ tr_ $ + mapM_ th_ ["Location", "Link"] + tbody_ $ + for_ (filterUnparseable links) $ \LinkInfo{..} -> + tr_ $ do + td_ $ toHtml linkLocation + td_ $ a_ [href_ linkUrl] (toHtml linkUrl) + where + filterUnparseable xs = [x | x <- xs, Unparseable <- [linkStatus x]] + +renderBrokenLinks :: Monad m => [LinkInfo] -> HtmlT m () +renderBrokenLinks links = do + h2_ "Broken Links" + table_ [class_ "sortable"] $ do + thead_ $ tr_ $ + mapM_ th_ ["Location", "Link", "Status", "Archival status"] + tbody_ $ + for_ (filterBroken links) $ \(LinkInfo{..}, reason) -> + tr_ $ do + td_ $ toHtml linkLocation + td_ $ a_ [href_ linkUrl] (toHtml linkUrl) + td_ $ toHtml reason + td_ $ renderArchivalStatus linkArchivalStatus + where + filterBroken xs = [(x, reason) | x <- xs, Broken reason <- [linkStatus x]] + +renderArchivalStatus :: Monad m => Either String ArchivalStatus -> HtmlT m () +renderArchivalStatus = \case + Left err -> "couldn't get info from archive.org: " <> toHtml err + Right ArchivalStatus{..} + | asAvailable -> do + a_ [href_ asUrl] (toHtml (T.toStrict (dateDashF asTimestamp))) + unless (asStatus == "200") $ + toHtml (format " (status: {})" asStatus :: Text) + | otherwise -> "unavailable" + +-- | Get status of a link on archive.org. 'Left' means that an error +-- happened when talking to archive.org. +getArchivalStatus :: Manager -> Url -> IO (Either String ArchivalStatus) +getArchivalStatus manager lnk = + handle (pure . Left . show @HttpException) $ do + req <- setQueryString [("url", Just (T.toByteString lnk))] <$> + parseRequest waybackUrl + fromJsonWith responseParser . responseBody <$!> httpLbs req manager + where + waybackUrl = "http://archive.org/wayback/available" + responseParser = A.withObject "archive.org response" $ + (A..: "archived_snapshots") >=> (A..: "closest") -- | Find all links in content, along with a human-readable description of -- where each link is located. @@ -954,34 +965,27 @@ findLinksItem item = findLinksMD item' ++ maybeToList (item^.link) findLinksMD :: Data a => a -> [Url] findLinksMD a = [url | MD.LINK url _ <- universeBi a] --- TODO: get rid of complicated data structures --- can be done when JSON parser is added -data ArchiveOrgResponse = - ArchiveOrgResponse { archivedSnapshots :: ArchivedSnapshot - } deriving (Show, Generic) +data ArchivalStatus = ArchivalStatus { + asAvailable :: Bool, -- ^ Whether the link is available + asUrl :: Url, -- ^ Link to archived page + asTimestamp :: UTCTime, -- ^ When the page was archived + asStatus :: Text } -- ^ HTTP status (200, 404, etc) + deriving (Eq, Show) -data ArchivedSnapshot = - ArchivedSnapshot { closest :: Closest - } deriving (Show, Generic) - -data Closest = - Closest { url' :: String - , timestamp :: UTCTime - } deriving (Show, Generic) - -instance A.FromJSON ArchiveOrgResponse where - parseJSON (A.Object v) = - ArchiveOrgResponse <$> v A..: "archived_snapshots" - parseJSON _ = mzero - -instance A.FromJSON ArchivedSnapshot where - parseJSON (A.Object v) = - ArchivedSnapshot <$> v A..: "closest" - parseJSON _ = mzero - -instance A.FromJSON Closest where - parseJSON = A.withObject "Closest" $ \o -> do - url' <- o A..: "url" - timestamp <- o A..: "timestamp" >>= - parseTimeM True defaultTimeLocale "%Y%m%d%H%M%S" - pure Closest{..} +-- For an example, look at archived_snapshots.closest in +-- . +-- +-- Here is sample JSON: +-- +-- { "status": "200" +-- , "available": true +-- , "url": "http://web.archive.org/web/20170819042701/http://example.com" +-- , "timestamp": "20170819042701" } +instance A.FromJSON ArchivalStatus where + parseJSON = A.withObject "ArchivalStatus" $ \o -> do + asAvailable <- o A..: "available" + asUrl <- o A..: "url" + asStatus <- o A..: "status" + asTimestamp <- o A..: "timestamp" >>= + parseTimeM True defaultTimeLocale "%Y%m%d%H%M%S" + pure ArchivalStatus{..} diff --git a/src/Guide/Views/Utils.hs b/src/Guide/Views/Utils.hs index 64e52b7..b558d2b 100644 --- a/src/Guide/Views/Utils.hs +++ b/src/Guide/Views/Utils.hs @@ -86,7 +86,6 @@ import qualified System.FilePath.Find as F -- Mustache (templates) import Text.Mustache.Plus import qualified Data.Aeson as A -import qualified Data.Aeson.Text as A import qualified Data.ByteString.Lazy.Char8 as BS import qualified Data.Semigroup as Semigroup import qualified Data.List.NonEmpty as NonEmpty From a8090e8cc6985d0db15d910ddd751cf5954d9be6 Mon Sep 17 00:00:00 2001 From: Artyom Date: Sun, 20 Aug 2017 16:48:08 +0300 Subject: [PATCH 6/9] Minor --- src/Guide/Handlers.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Guide/Handlers.hs b/src/Guide/Handlers.hs index 06e7774..d04fc0a 100644 --- a/src/Guide/Handlers.hs +++ b/src/Guide/Handlers.hs @@ -318,7 +318,7 @@ addMethods = do otherMethods :: GuideM ctx () otherMethods = do - -- Moving things + -- # Moving things -- Move item Spock.post (moveRoute itemVar) $ \itemId -> do direction :: Text <- param' "direction" @@ -332,7 +332,7 @@ otherMethods = do edit <- dbUpdate (MoveTrait itemId traitId (direction == "up")) addEdit edit --- Deleting things + -- # Deleting things -- Delete category Spock.post (deleteRoute categoryVar) $ \catId -> uncache (CacheCategory catId) $ do @@ -349,7 +349,7 @@ otherMethods = do mbEdit <- dbUpdate (DeleteTrait itemId traitId) mapM_ addEdit mbEdit - -- Feeds + -- # Feeds -- TODO: this link shouldn't be absolute [absolute-links] baseUrl <- (// "haskell") . _baseUrl <$> getConfig From c9fe5866e799fa75ebd139003798d22da6208a8b Mon Sep 17 00:00:00 2001 From: Artyom Date: Sun, 20 Aug 2017 16:48:27 +0300 Subject: [PATCH 7/9] Show login errors --- src/Guide/Main.hs | 10 ++++++---- src/Guide/State.hs | 9 +++++---- 2 files changed, 11 insertions(+), 8 deletions(-) diff --git a/src/Guide/Main.hs b/src/Guide/Main.hs index afd16b9..954d6ac 100644 --- a/src/Guide/Main.hs +++ b/src/Guide/Main.hs @@ -336,13 +336,15 @@ loginAction = do loginAttempt <- dbQuery $ LoginUser loginEmail (T.toByteString loginUserPassword) case loginAttempt of - Just user -> do + Right user -> do modifySession (sessionUserID .~ Just (user ^. userID)) Spock.redirect "/" - -- TODO: show error message/validation of input - Nothing -> do + -- TODO: *properly* show error message/validation of input + Left err -> do formHtml <- protectForm loginFormView v - lucidWithConfig $ renderRegister formHtml + lucidWithConfig $ renderRegister $ do + div_ $ toHtml ("Error: " <> err) + formHtml logoutAction :: GuideAction ctx () logoutAction = do diff --git a/src/Guide/State.hs b/src/Guide/State.hs index 34b771d..8c4ee56 100644 --- a/src/Guide/State.hs +++ b/src/Guide/State.hs @@ -752,15 +752,16 @@ deleteUser key = do -- | Given an email address and a password, return the user if it exists -- and the password is correct. -loginUser :: Text -> ByteString -> Acid.Query GlobalState (Maybe User) +loginUser :: Text -> ByteString -> Acid.Query GlobalState (Either String User) loginUser email password = do matches <- filter (\u -> u ^. userEmail == email) . toList <$> view users case matches of [user] -> if verifyUser user password - then return $ Just user - else return $ Nothing - _ -> return Nothing + then return $ Right user + else return $ Left "wrong password" + [] -> return $ Left "user not found" + _ -> return $ Left "more than one user found, please contact the admin" -- | Global logout of all of a user's active sessions logoutUserGlobally :: Uid User -> Acid.Update GlobalState () From 2038d4722983313bc94dfe9dca05232acd8e21a5 Mon Sep 17 00:00:00 2001 From: Artyom Date: Sun, 20 Aug 2017 16:48:35 +0300 Subject: [PATCH 8/9] Delete the admin user that came with the official database --- src/Guide/Main.hs | 1 + src/Guide/State.hs | 10 ++++++++-- 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/src/Guide/Main.hs b/src/Guide/Main.hs index 954d6ac..0f813d4 100644 --- a/src/Guide/Main.hs +++ b/src/Guide/Main.hs @@ -448,6 +448,7 @@ installTerminationCatcher thread = void $ do -- The user won't be added if it exists already. createAdminUser :: GuideApp () createAdminUser = do + dbUpdate DeleteAllUsers pass <- T.toByteString . _adminPassword <$> getConfig user <- makeUser "admin" "admin@guide.aelve.com" pass void $ dbUpdate $ CreateUser (user & userIsAdmin .~ True) diff --git a/src/Guide/State.hs b/src/Guide/State.hs index 8c4ee56..99d10d4 100644 --- a/src/Guide/State.hs +++ b/src/Guide/State.hs @@ -79,7 +79,7 @@ module Guide.State LoadSession(..), StoreSession(..), DeleteSession(..), GetSessions(..), - GetUser(..), CreateUser(..), DeleteUser(..), + GetUser(..), CreateUser(..), DeleteUser(..), DeleteAllUsers(..), LoginUser(..), GetAdminUsers(..) @@ -750,6 +750,12 @@ deleteUser key = do logoutUserGlobally key setDirty +deleteAllUsers :: Acid.Update GlobalState () +deleteAllUsers = do + mapM_ logoutUserGlobally . M.keys =<< use users + users .= mempty + setDirty + -- | Given an email address and a password, return the user if it exists -- and the password is correct. loginUser :: Text -> ByteString -> Acid.Query GlobalState (Either String User) @@ -813,7 +819,7 @@ makeAcidic ''GlobalState [ 'loadSession, 'storeSession, 'deleteSession, 'getSessions, -- users - 'getUser, 'createUser, 'deleteUser, + 'getUser, 'createUser, 'deleteUser, 'deleteAllUsers, 'loginUser, 'getAdminUsers From e207d4a8c6a9940b241a9497b01eec6b2b24a828 Mon Sep 17 00:00:00 2001 From: Artyom Date: Sun, 20 Aug 2017 21:31:22 +0300 Subject: [PATCH 9/9] Move archive.org utils to a separate module --- guide.cabal | 1 + src/Guide/Archival.hs | 65 +++++++++++++++++++++++++++++++++++++++++++ src/Guide/Views.hs | 39 +------------------------- 3 files changed, 67 insertions(+), 38 deletions(-) create mode 100644 src/Guide/Archival.hs diff --git a/guide.cabal b/guide.cabal index 0ee176a..704837e 100644 --- a/guide.cabal +++ b/guide.cabal @@ -63,6 +63,7 @@ library Guide.Diff.Tokenize Guide.Diff.Merge Guide.Markdown + Guide.Archival Guide.Search Guide.JS Guide.Views diff --git a/src/Guide/Archival.hs b/src/Guide/Archival.hs new file mode 100644 index 0000000..ba97c17 --- /dev/null +++ b/src/Guide/Archival.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE OverloadedStrings #-} + + +-- | Methods for working with archive.org. Right now the admin interface +-- provides a list of broken links together with links to their archived +-- copies; in the future we might add automatic archival and automatic link +-- replacement. +module Guide.Archival +( + ArchivalStatus(..), + getArchivalStatus, +) +where + + +import Imports + +-- text +import qualified Data.Text.All as T +-- JSON +import qualified Data.Aeson as A +-- network +import Network.HTTP.Client + +import Guide.Utils + + +-- | Get status of a link on archive.org. +-- +-- 'Left' means that an error happened when connecting to archive.org, or +-- that its response couldn't be parsed. +getArchivalStatus :: Manager -> Url -> IO (Either String ArchivalStatus) +getArchivalStatus manager lnk = + handle (pure . Left . show @HttpException) $ do + req <- setQueryString [("url", Just (T.toByteString lnk))] <$> + parseRequest waybackUrl + fromJsonWith responseParser . responseBody <$!> httpLbs req manager + where + waybackUrl = "http://archive.org/wayback/available" + responseParser = A.withObject "archive.org response" $ + (A..: "archived_snapshots") >=> (A..: "closest") + +data ArchivalStatus = ArchivalStatus { + asAvailable :: Bool, -- ^ Whether the link is available + asUrl :: Url, -- ^ Link to archived page + asTimestamp :: UTCTime, -- ^ When the page was archived + asStatus :: Text } -- ^ HTTP status ("200", "404", etc) + deriving (Eq, Show) + +-- For an example, look at archived_snapshots.closest in +-- : +-- +-- { "status": "200" +-- , "available": true +-- , "url": "http://web.archive.org/web/20170819042701/http://example.com" +-- , "timestamp": "20170819042701" } +instance A.FromJSON ArchivalStatus where + parseJSON = A.withObject "ArchivalStatus" $ \o -> do + asAvailable <- o A..: "available" + asUrl <- o A..: "url" + asStatus <- o A..: "status" + asTimestamp <- o A..: "timestamp" >>= + parseTimeM True defaultTimeLocale "%Y%m%d%H%M%S" + pure ArchivalStatus{..} diff --git a/src/Guide/Views.hs b/src/Guide/Views.hs index e6bfdfb..afbacab 100644 --- a/src/Guide/Views.hs +++ b/src/Guide/Views.hs @@ -67,6 +67,7 @@ import Guide.Utils import Guide.JS (JS(..)) import qualified Guide.JS as JS import Guide.Markdown +import Guide.Archival import Guide.Diff hiding (DiffChunk) import qualified Guide.Diff as Diff import Guide.Cache @@ -926,19 +927,6 @@ renderArchivalStatus = \case toHtml (format " (status: {})" asStatus :: Text) | otherwise -> "unavailable" --- | Get status of a link on archive.org. 'Left' means that an error --- happened when talking to archive.org. -getArchivalStatus :: Manager -> Url -> IO (Either String ArchivalStatus) -getArchivalStatus manager lnk = - handle (pure . Left . show @HttpException) $ do - req <- setQueryString [("url", Just (T.toByteString lnk))] <$> - parseRequest waybackUrl - fromJsonWith responseParser . responseBody <$!> httpLbs req manager - where - waybackUrl = "http://archive.org/wayback/available" - responseParser = A.withObject "archive.org response" $ - (A..: "archived_snapshots") >=> (A..: "closest") - -- | Find all links in content, along with a human-readable description of -- where each link is located. findLinks :: GlobalState -> [(Url, Text)] @@ -964,28 +952,3 @@ findLinksItem item = findLinksMD item' ++ maybeToList (item^.link) -- | Find all Markdown links in /any/ structure, using generics. findLinksMD :: Data a => a -> [Url] findLinksMD a = [url | MD.LINK url _ <- universeBi a] - -data ArchivalStatus = ArchivalStatus { - asAvailable :: Bool, -- ^ Whether the link is available - asUrl :: Url, -- ^ Link to archived page - asTimestamp :: UTCTime, -- ^ When the page was archived - asStatus :: Text } -- ^ HTTP status (200, 404, etc) - deriving (Eq, Show) - --- For an example, look at archived_snapshots.closest in --- . --- --- Here is sample JSON: --- --- { "status": "200" --- , "available": true --- , "url": "http://web.archive.org/web/20170819042701/http://example.com" --- , "timestamp": "20170819042701" } -instance A.FromJSON ArchivalStatus where - parseJSON = A.withObject "ArchivalStatus" $ \o -> do - asAvailable <- o A..: "available" - asUrl <- o A..: "url" - asStatus <- o A..: "status" - asTimestamp <- o A..: "timestamp" >>= - parseTimeM True defaultTimeLocale "%Y%m%d%H%M%S" - pure ArchivalStatus{..}