Merge pull request #189 from aelve/archive-links

Add archive.org data to links page

.gitignore

@@ -20,6 +20,8 @@ cabal.config
 TAGS
 .DS_Store
 *~
+*.swp
+*.swo
 *#
 state/
 config.json

guide.cabal

@@ -63,6 +63,7 @@ library
       Guide.Diff.Tokenize
       Guide.Diff.Merge
     Guide.Markdown
+    Guide.Archival
     Guide.Search
     Guide.JS
     Guide.Views

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
+-- <http://archive.org/wayback/available?url=example.com>:
+--
+-- { "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{..}

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
 

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,15 @@ createCheckpoint =
      });
   |]
 
+saveToArchiveOrg :: JSFunction a => a
+saveToArchiveOrg =
+  makeJSFunction "saveToArchiveOrg" ["link"]
+  [text|
+    $.post('http://web.archive.org/save/' + link)
+      .done(function () {
+        console.log(link + " saved to archive.org")
+      });
+  |]
 -- When adding a function, don't forget to add it to 'allJSFunctions'!
 
 escapeJSString :: Text -> Text
@@ -726,4 +736,3 @@ selectChildren a b = JQuerySelector $ format "{} > {}" a b
 
 selectSection :: JQuerySelector -> Text -> JQuerySelector
 selectSection a b = JQuerySelector $ format "{} > .section.{}" a 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
@@ -446,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)

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,17 +750,24 @@ 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 (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 ()
@@ -812,7 +819,7 @@ makeAcidic ''GlobalState [
   'loadSession, 'storeSession, 'deleteSession, 'getSessions,
 
   -- users
-  'getUser, 'createUser, 'deleteUser, 
+  'getUser, 'createUser, 'deleteUser, 'deleteAllUsers,
   'loginUser,
 
   'getAdminUsers

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
 ----------------------------------------------------------------------------

src/Guide/Views.hs

@@ -1,7 +1,9 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE TypeApplications    #-}
+{-# LANGUAGE QuasiQuotes         #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE ExplicitForAll      #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 
 {- |
@@ -65,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
@@ -808,8 +811,20 @@ on those <div>s.
 
 data LinkStatus = OK | Unparseable | Broken String deriving Show
 
+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 :: (MonadIO m) => GlobalState -> HtmlT m ()
+renderAdminLinks :: forall m . (MonadIO m) => GlobalState -> HtmlT m ()
 renderAdminLinks globalState = do
   head_ $ do
     includeJS "/js.js"
@@ -828,7 +843,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')
@@ -838,56 +853,80 @@ renderAdminLinks globalState = do
                       ) `catch` (return . handleHttpException)
                     else
                       pure Unparseable
-            pure (toHtml location, a_ [href_ lnk] (toHtml lnk), resp)
-      let (ok, unparseable, broken) = sortLinks fullList
-
-      h2_ "Broken Links"
-      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
-            tr_ $ do
-              td_ location
-              td_ lnk
-              td_ $ toHtml reason
-      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
-              tr_ $ do
-                td_ cat
-                td_ l
-      h2_ "OK Links"
-      table_ [class_ "sortable"] $ do
-          thead_ $ tr_ $ do
-            th_ [class_ "sorttable_nosort"] "Category"
-            th_ [class_ "sorttable_nosort"] "Link"
-          tbody_ $ do
-            for_ ok $ \(cat, l) -> do
-              tr_ $ do
-                td_ cat
-                td_ l
+            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
 
-  sortLinks :: [(a, b, LinkStatus)] -> ([(a, b)], [(a, b)], [(a, b, String)])
-  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))
-
+  -- Link + a text description of where that link was found in Guide
   allLinks :: [(Url, Text)]
   allLinks = ordNub (findLinks globalState)
 
+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"
+
 -- | Find all links in content, along with a human-readable description of
 -- where each link is located.
 findLinks :: GlobalState -> [(Url, Text)]

src/Guide/Views/Utils.hs

@@ -86,8 +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.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 +294,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]