1
1
mirror of https://github.com/aelve/guide.git synced 2024-12-23 12:52:31 +03:00

[#124] Add button 'Save to Archive.org'

This commit is contained in:
vrom911 2017-08-14 20:07:56 +03:00 committed by Artyom
parent 554dce8a83
commit fee7a6d1bd
No known key found for this signature in database
GPG Key ID: B8E35A33FF522710
2 changed files with 54 additions and 35 deletions

View File

@ -58,7 +58,8 @@ allJSFunctions = JS . T.unlines . map fromJS $ [
-- Admin things -- Admin things
acceptEdit, undoEdit, acceptEdit, undoEdit,
acceptBlock, undoBlock, acceptBlock, undoBlock,
createCheckpoint ] createCheckpoint,
saveToArchiveOrg]
-- | A class for things that can be converted to Javascript syntax. -- | A class for things that can be converted to Javascript syntax.
class ToJS a where toJS :: a -> JS 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'! -- When adding a function, don't forget to add it to 'allJSFunctions'!
escapeJSString :: Text -> Text escapeJSString :: Text -> Text
@ -726,4 +738,3 @@ selectChildren a b = JQuerySelector $ format "{} > {}" a b
selectSection :: JQuerySelector -> Text -> JQuerySelector selectSection :: JQuerySelector -> Text -> JQuerySelector
selectSection a b = JQuerySelector $ format "{} > .section.{}" a b selectSection a b = JQuerySelector $ format "{} > .section.{}" a b

View File

@ -41,7 +41,6 @@ import Data.Monoid ((<>))
-- Text -- Text
import qualified Data.Text.All as T import qualified Data.Text.All as T
import NeatInterpolation import NeatInterpolation
import Data.ByteString.Lazy (toStrict)
-- Web -- Web
import Lucid hiding (for_) import Lucid hiding (for_)
-- Network -- Network
@ -840,60 +839,69 @@ renderAdminLinks globalState = do
) `catch` (return . handleHttpException) ) `catch` (return . handleHttpException)
else else
pure Unparseable pure Unparseable
archDate <- getArchieveOrgLatestDate manager lnk (archDate, archUrl) <- liftIO $ getArchieveOrgData manager lnk
pure (toHtml location, a_ [href_ lnk] (toHtml lnk), resp, toHtml archDate) pure ( toHtml location
, lnk
, resp
, (toHtml archDate, a_ [href_ (T.pack archUrl)] (toHtml $ show archUrl))
)
let (ok, unparseable, broken) = sortLinks fullList let (ok, unparseable, broken) = sortLinks fullList
-- archiveAnswer <- liftIO $ do -- archiveAnswer <- liftIO $ do
-- requestArch <- parseRequest "http://archive.org/wayback/available?url=example.com" -- requestArch <- parseRequest "http://archive.org/wayback/available?url=example.com"
-- respArch <- responseBody <$> httpLbs requestArch manager -- respArch <- responseBody <$> httpLbs requestArch manager
-- -- let respBr = singleton (BS.c2w '[') <> resp <> singleton (BS.c2w ']')
-- d <- (A.eitherDecode <$> (pure respArch)) :: IO (Either String ArchiveOrgResponse) -- d <- (A.eitherDecode <$> (pure respArch)) :: IO (Either String ArchiveOrgResponse)
-- case d of -- case d of
-- Left err -> putStrLn err -- Left err -> putStrLn err
-- Right ps -> print $ timestamp $ closest $ archivedSnapshots ps -- Right ps -> print $ toProperDate $ timestamp $ closest $ archivedSnapshots ps
-- pure respArch -- pure respArch
-- --
-- div_ $ toHtml $ toStrict archiveAnswer -- div_ $ toHtml $ toStrict archiveAnswer
-- div_ $ button "To Archive" [] (JS.saveToArchiveOrg [JS.toJS $ T.pack "example.com"])
table_ [class_ "sortable"] $ do table_ [class_ "sortable"] $ do
thead_ $ tr_ $ do thead_ $ tr_ $ do
th_ [class_ "sorttable_nosort"] "Category" th_ [class_ "sorttable_nosort"] "Category"
th_ [class_ "sorttable_nosort"] "Link" th_ [class_ "sorttable_nosort"] "Link"
th_ "Status" th_ "Status"
th_ "Latest archieve date" th_ "Saved page"
tbody_ $ tbody_ $
for_ broken $ \(location, lnk, reason, d) -> for_ broken $ \(location, lnk, reason, (_, archUrl)) ->
tr_ $ do tr_ $ do
td_ location td_ location
td_ lnk td_ $ a_ [href_ lnk] (toHtml lnk)
td_ $ toHtml reason td_ $ toHtml reason
td_ d td_ archUrl
h2_ "Unparseable Links" h2_ "Unparseable Links"
table_ [class_ "sortable"] $ do table_ [class_ "sortable"] $ do
thead_ $ tr_ $ do thead_ $ tr_ $ do
th_ [class_ "sorttable_nosort"] "Category" th_ [class_ "sorttable_nosort"] "Category"
th_ [class_ "sorttable_nosort"] "Link" th_ [class_ "sorttable_nosort"] "Link"
tbody_ $ tbody_ $
for_ unparseable $ \(cat, l) -> for_ unparseable $ \(location, lnk) ->
tr_ $ do tr_ $ do
td_ cat td_ location
td_ l td_ $ a_ [href_ lnk] (toHtml lnk)
h2_ "OK Links" h2_ "OK Links"
table_ [class_ "sortable"] $ do table_ [class_ "sortable"] $ do
thead_ $ tr_ $ do thead_ $ tr_ $ do
th_ [class_ "sorttable_nosort"] "Category" th_ [class_ "sorttable_nosort"] "Category"
th_ [class_ "sorttable_nosort"] "Link" th_ [class_ "sorttable_nosort"] "Link"
th_ [class_ "sorttable_nosort"] "Latest archieve date" th_ [class_ "sorttable_nosort"] "Latest archieve date"
th_ "Save to Archive"
tbody_ $ tbody_ $
for_ ok $ \(cat, l, d) -> for_ ok $ \(location, lnk, (dt, _)) ->
tr_ $ do tr_ $ do
td_ cat td_ location
td_ l td_ $ a_ [href_ lnk] (toHtml lnk)
td_ d td_ dt
td_ $ button "To Archive" [] (JS.saveToArchiveOrg [JS.toJS lnk])
where where
handleHttpException :: HttpException -> LinkStatus handleHttpException :: HttpException -> LinkStatus
handleHttpException (HttpExceptionRequest _ x) = Broken $ show x handleHttpException (HttpExceptionRequest _ x) = Broken $ show x
handleHttpException (InvalidUrlException _ x) = Broken 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 :: [(a, b, LinkStatus, c)] -> ([(a, b, c)], [(a, b)], [(a, b, String, c)])
sortLinks = foldr sortLink ([], [], []) sortLinks = foldr sortLink ([], [], [])
@ -904,14 +912,16 @@ renderAdminLinks globalState = do
allLinks :: [(Url, Text)] allLinks :: [(Url, Text)]
allLinks = ordNub (findLinks globalState) allLinks = ordNub (findLinks globalState)
getArchieveOrgLatestDate manager lnk = do getArchieveOrgData manager lnk = (do
requestArch <- parseRequest $ "http://archive.org/wayback/available?url="+|lnk|+"" requestArch <- parseRequest $ "http://archive.org/wayback/available?url="+|lnk|+""
respArch <- responseBody <$> httpLbs requestArch manager respArch <- responseBody <$> httpLbs requestArch manager
d <- (A.decode <$> pure respArch) :: IO (Maybe ArchiveOrgResponse) d <- (A.decode <$> pure respArch) :: IO (Maybe ArchiveOrgResponse)
let archDate = case d of let archRes = case d of
Just arch -> timestamp $ closest $ archivedSnapshots arch Just arch -> ( show $ toProperDate $ timestamp $ closest $ archivedSnapshots arch
Nothing -> "none" , url' $ closest $ archivedSnapshots arch
pure archDate )
Nothing -> ("none", "none")
pure archRes) `catch` handleHttpExceptionDecode
-- | Find all links in content, along with a human-readable description of -- | Find all links in content, along with a human-readable description of
-- where each link is located. -- where each link is located.
@ -940,24 +950,21 @@ findLinksMD :: Data a => a -> [Url]
findLinksMD a = [url | MD.LINK url _ <- universeBi a] findLinksMD a = [url | MD.LINK url _ <- universeBi a]
data ArchiveOrgResponse = data ArchiveOrgResponse =
ArchiveOrgResponse { url :: String ArchiveOrgResponse { archivedSnapshots :: ArchivedSnapshot
, archivedSnapshots :: ArchivedSnapshot
} deriving (Show, Generic) } deriving (Show, Generic)
data ArchivedSnapshot = data ArchivedSnapshot =
ArchivedSnapshot { closest :: Closest } deriving (Show, Generic) ArchivedSnapshot { closest :: Closest
} deriving (Show, Generic)
data Closest = data Closest =
Closest { status' :: String Closest { url' :: String
, available :: Bool
, url' :: String
, timestamp :: String , timestamp :: String
} deriving (Show, Generic) } deriving (Show, Generic)
instance A.FromJSON ArchiveOrgResponse where instance A.FromJSON ArchiveOrgResponse where
parseJSON (A.Object v) = parseJSON (A.Object v) =
ArchiveOrgResponse <$> v A..: "url" ArchiveOrgResponse <$> v A..: "archived_snapshots"
<*> v A..: "archived_snapshots"
parseJSON _ = mzero parseJSON _ = mzero
instance A.FromJSON ArchivedSnapshot where instance A.FromJSON ArchivedSnapshot where
@ -967,8 +974,9 @@ instance A.FromJSON ArchivedSnapshot where
instance A.FromJSON Closest where instance A.FromJSON Closest where
parseJSON (A.Object v) = parseJSON (A.Object v) =
Closest <$> v A..: "status" Closest <$> v A..: "url"
<*> v A..: "available"
<*> v A..: "url"
<*> v A..: "timestamp" <*> v A..: "timestamp"
parseJSON _ = mzero parseJSON _ = mzero
toProperDate :: String -> UTCTime
toProperDate = parseTimeOrError True defaultTimeLocale "%Y%m%d%H%M%S"