add host to useragent

.cf-clearance

@@ -0,0 +1 @@
+cf_clearance=96f0dfc0741239f896f9443f721c94c8fafa82b0-1595277120-GJDOCYQO

espial.cabal

@@ -1,10 +1,10 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.31.2.
+-- This file has been generated from package.yaml by hpack version 0.33.0.
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: b6f4cdc1abf4e7a6b5bbc1382963c22cc62bbbe8c4ae5e5394cf6fe5fc1ff9cb
+-- hash: 1e6238118c05016ee28c808f6f736f03c5c719ed69576390d95900d6a5e85cee
 
 name:           espial
 version:        0.0.8
@@ -123,7 +123,7 @@ library
       Paths_espial
   hs-source-dirs:
       src
-  default-extensions: BangPatterns CPP ConstraintKinds DataKinds DeriveDataTypeable DeriveGeneric DerivingStrategies EmptyDataDecls FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NoImplicitPrelude OverloadedStrings PolyKinds PolymorphicComponents QuasiQuotes Rank2Types RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators TypeSynonymInstances UndecidableInstances ViewPatterns
+  default-extensions: BangPatterns BlockArguments CPP ConstraintKinds DataKinds DeriveDataTypeable DeriveGeneric DerivingStrategies EmptyDataDecls FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NoImplicitPrelude OverloadedStrings PolyKinds PolymorphicComponents QuasiQuotes Rank2Types RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators TypeSynonymInstances UndecidableInstances ViewPatterns
   build-depends:
       aeson >=1.4
     , attoparsec
@@ -194,7 +194,7 @@ executable espial
       Paths_espial
   hs-source-dirs:
       app
-  default-extensions: BangPatterns CPP ConstraintKinds DataKinds DeriveDataTypeable DeriveGeneric DerivingStrategies EmptyDataDecls FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NoImplicitPrelude OverloadedStrings PolyKinds PolymorphicComponents QuasiQuotes Rank2Types RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators TypeSynonymInstances UndecidableInstances ViewPatterns
+  default-extensions: BangPatterns BlockArguments CPP ConstraintKinds DataKinds DeriveDataTypeable DeriveGeneric DerivingStrategies EmptyDataDecls FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NoImplicitPrelude OverloadedStrings PolyKinds PolymorphicComponents QuasiQuotes Rank2Types RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators TypeSynonymInstances UndecidableInstances ViewPatterns
   ghc-options: -threaded -rtsopts -with-rtsopts=-N
   build-depends:
       aeson >=1.4
@@ -263,7 +263,7 @@ executable migration
       Paths_espial
   hs-source-dirs:
       app/migration
-  default-extensions: BangPatterns CPP ConstraintKinds DataKinds DeriveDataTypeable DeriveGeneric DerivingStrategies EmptyDataDecls FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NoImplicitPrelude OverloadedStrings PolyKinds PolymorphicComponents QuasiQuotes Rank2Types RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators TypeSynonymInstances UndecidableInstances ViewPatterns
+  default-extensions: BangPatterns BlockArguments CPP ConstraintKinds DataKinds DeriveDataTypeable DeriveGeneric DerivingStrategies EmptyDataDecls FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NoImplicitPrelude OverloadedStrings PolyKinds PolymorphicComponents QuasiQuotes Rank2Types RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators TypeSynonymInstances UndecidableInstances ViewPatterns
   ghc-options: -threaded -rtsopts -with-rtsopts=-N
   build-depends:
       aeson >=1.4
@@ -337,7 +337,7 @@ test-suite test
       Paths_espial
   hs-source-dirs:
       test
-  default-extensions: BangPatterns CPP ConstraintKinds DataKinds DeriveDataTypeable DeriveGeneric DerivingStrategies EmptyDataDecls FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NoImplicitPrelude OverloadedStrings PolyKinds PolymorphicComponents QuasiQuotes Rank2Types RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators TypeSynonymInstances UndecidableInstances ViewPatterns
+  default-extensions: BangPatterns BlockArguments CPP ConstraintKinds DataKinds DeriveDataTypeable DeriveGeneric DerivingStrategies EmptyDataDecls FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NoImplicitPrelude OverloadedStrings PolyKinds PolymorphicComponents QuasiQuotes Rank2Types RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators TypeSynonymInstances UndecidableInstances ViewPatterns
   ghc-options: -Wall
   build-depends:
       aeson >=1.4

package.yaml

@@ -42,6 +42,7 @@ extra-source-files:
 
 default-extensions:
 - BangPatterns
+- BlockArguments
 - CPP
 - ConstraintKinds
 - DataKinds

src/Application.hs

@@ -139,8 +139,8 @@ develMain = develMainHelper getApplicationDev
 -- forkEKG :: App -> IO ()
 -- forkEKG foundation = 
 --   let settings = appSettings foundation in
---   for_ (appEkgHost settings) $ \ekgHost ->
+--   for_ (appEkgHost settings) \ekgHost ->
---     for_ (appEkgPort settings) $ \ekgPort ->
+--     for_ (appEkgPort settings) \ekgPort ->
 --       EKG.forkServerWith
 --         (appMetrics foundation ^. MM.metricsStore)
 --         (encodeUtf8 ekgHost)

src/Foundation.hs

@@ -49,7 +49,7 @@ instance YesodPersistRunner App where
 -- Yesod
 
 instance Yesod App where
-    approot = ApprootRequest $ \app req ->
+    approot = ApprootRequest \app req ->
         case appRoot (appSettings app) of
             Nothing -> getApprootText guessApproot app req
             Just root -> root
@@ -71,7 +71,7 @@ instance Yesod App where
         mcurrentRoute <- getCurrentRoute
         -- void $ mapM (incrementRouteEKG req) mcurrentRoute
         let msourceCodeUri = appSourceCodeUri (appSettings master)
-        pc <- widgetToPageContent $ do
+        pc <- widgetToPageContent do
             setTitle "Espial"
             addAppScripts
             addStylesheet (StaticR css_tachyons_min_css)
@@ -132,7 +132,7 @@ popupLayout widget = do
     mmsg <- getMessage
     musername <- maybeAuthUsername
     let msourceCodeUri = appSourceCodeUri (appSettings master)
-    pc <- widgetToPageContent $ do
+    pc <- widgetToPageContent do
       addAppScripts
       addStylesheet (StaticR css_tachyons_min_css)
       addStylesheet (StaticR css_popup_css)

src/Handler/AccountSettings.hs

@@ -8,7 +8,7 @@ getAccountSettingsR = do
   (_, user) <- requireAuthPair
   let accountSettingsEl = "accountSettings" :: Text
   let accountSettings = toAccountSettingsForm user
-  defaultLayout $ do
+  defaultLayout do
     $(widgetFile "user-settings")
     toWidgetBody [julius|
         app.userR = "@{UserR (UserNameP $ userName user)}";

src/Handler/Add.hs

@@ -16,7 +16,7 @@ getAddViewR = do
 
   let renderEl = "addForm" :: Text
 
-  popupLayout $ do
+  popupLayout do
     toWidget [whamlet|
       <div id="#{ renderEl }">
     |]

src/Handler/Archive.hs

@@ -15,6 +15,7 @@ import qualified Web.FormUrlEncoded as WH
 -- import qualified Control.Monad.Metrics as MM
 import HTMLEntities.Decoder (htmlEncodedText)
 import Data.Text.Lazy.Builder (toLazyText)
+import Network.Wai (requestHeaderHost)
 
 shouldArchiveBookmark :: User -> Key Bookmark -> Handler Bool
 shouldArchiveBookmark user kbid = do
@@ -35,7 +36,7 @@ archiveBookmarkUrl kbid url =
       $(logError) (pack e)
     Right submitInfo ->  do
         userId <- requireAuthId
-        let req = _buildArchiveSubmitRequest submitInfo url
+        req <- _buildArchiveSubmitRequest submitInfo url
         -- MM.increment "archive.submit"  
         res <- liftIO $ NH.httpLbs req  =<< NH.getGlobalManager
         let status = NH.responseStatus res
@@ -71,32 +72,19 @@ _parseRefreshHeaderUrl h = do
     then Just $ decodeUtf8 u
     else Nothing
 
-_buildArchiveSubmitRequest :: (String, String) -> String -> NH.Request
-_buildArchiveSubmitRequest (action, submitId) href =
-  NH.parseRequest_ ("POST " <> action) & \r ->
-    r { NH.requestHeaders =
-        [ ("User-Agent", _archiveUserAgent)
-        , ("Content-Type", "application/x-www-form-urlencoded")
-        ]
-      , NH.requestBody = NH.RequestBodyLBS $ WH.urlEncodeAsForm ((
-        [ ("submitid" , submitId)
-        , ("url", href)
-        ]) :: [(String, String)])
-      , NH.redirectCount = 0
-      }
-
 _fetchArchiveSubmitInfo :: Handler (Either String (String , String))
 _fetchArchiveSubmitInfo = do
   -- MM.increment "archive.fetchSubmitId"  
-  res <- liftIO $ NH.httpLbs (buildSimpleRequest "https://archive.li/") =<< NH.getGlobalManager
+  req <- buildRequest "https://archive.li/" 
+  res <- liftIO $ NH.httpLbs req =<< NH.getGlobalManager
   -- MM.increment ("archive.fetchSubmitId_status_" <> (pack.show) (NH.statusCode (NH.responseStatus res))) 
   let body = LBS.toStrict (responseBody res)
       action = _parseSubstring (AP8.string "action=\"") (AP8.notChar '"') body
       submitId = _parseSubstring (AP8.string "submitid\" value=\"") (AP8.notChar '"') body
-  pure $ (,) <$> action <*> submitId
+  if statusCode (responseStatus res) == 200
-
+    then pure $ (,) <$> action <*> submitId
-_archiveUserAgent :: ByteString
+    else pure $ Left $ "Invalid statusCode: " <> show (responseStatus res)
-_archiveUserAgent = "espial"
+  
 
 _parseSubstring :: AP8.Parser ByteString -> AP8.Parser Char -> BS.ByteString -> Either String String
 _parseSubstring start inner res = do
@@ -109,7 +97,8 @@ fetchPageTitle :: String -> Handler (Either String Text)
 fetchPageTitle url =
   do
      -- MM.increment "fetchPageTitle"
-     res <- liftIO $ NH.httpLbs (buildSimpleRequest url) =<< NH.getGlobalManager
+     req <- buildRequest url
+     res <- liftIO $ NH.httpLbs req =<< NH.getGlobalManager
      let body = LBS.toStrict (responseBody res)
      pure (decodeHtmlBs <$> parseTitle body)
      `catch` (\(e :: SomeException) -> do
@@ -118,7 +107,7 @@ fetchPageTitle url =
                 pure (Left (show e)))
   where
     parseTitle bs =
-      (flip AP.parseOnly) bs $ do
+      (flip AP.parseOnly) bs do
         _ <- skipAnyTill (AP.string "<title")
         _ <- skipAnyTill (AP.string ">")
         let lt = toEnum (ord '<')
@@ -126,7 +115,34 @@ fetchPageTitle url =
     decodeHtmlBs = toStrict . toLazyText . htmlEncodedText . decodeUtf8
     skipAnyTill end = go where go = end *> pure () <|> AP.anyWord8 *> go
 
-buildSimpleRequest :: String -> Request
+_buildArchiveSubmitRequest :: (String, String) -> String -> Handler NH.Request
-buildSimpleRequest url =
+_buildArchiveSubmitRequest (action, submitId) href = do
-  NH.parseRequest_ url & \r ->
+  req <- buildRequest ("POST " <> action) 
-    r {NH.requestHeaders = [("User-Agent", _archiveUserAgent)]}
+  pure $ req
+    { NH.requestHeaders = ("Content-Type", "application/x-www-form-urlencoded") : NH.requestHeaders req
+    , NH.requestBody =
+        NH.RequestBodyLBS $
+        WH.urlEncodeAsForm
+            (([("submitid", submitId), ("url", href)]) :: [(String, String)])
+    , NH.redirectCount = 0
+    }
+
+buildRequest :: String -> Handler Request
+buildRequest url = do
+  ua <- _archiveUserAgent
+  pure $ NH.parseRequest_ url & \r ->
+    r { NH.requestHeaders =
+          [ ("Cache-Control", "max-age=0")
+          , ("Connection", "keep-alive")
+          , ("DNT", "1")
+          , ("Host", "archive.li")
+          , ("Upgrade-Insecure-Requests", "1")
+          , ("User-Agent", ua)
+          ]
+      }
+
+_archiveUserAgent :: Handler ByteString
+_archiveUserAgent = do
+  mHost <- pure . requestHeaderHost . reqWaiRequest =<< getRequest
+  pure $ ("espial-" <>) (maybe "" (BS8.takeWhile (/= ':')) mHost)
+

src/Handler/Edit.hs

@@ -11,7 +11,7 @@ import Import
 deleteDeleteR :: Int64 -> Handler Html
 deleteDeleteR bid = do
   userId <- requireAuthId
-  runDB $ do
+  runDB do
     let k_bid = BookmarkKey bid
     _ <- requireResource userId k_bid
     deleteCascade k_bid
@@ -20,7 +20,7 @@ deleteDeleteR bid = do
 postReadR :: Int64 -> Handler Html
 postReadR bid = do
   userId <- requireAuthId
-  runDB $ do
+  runDB do
     let k_bid = BookmarkKey bid
     _ <- requireResource userId k_bid
     update k_bid [BookmarkToRead =. False]
@@ -37,7 +37,7 @@ postUnstarR bid = _setSelected bid False
 _setSelected :: Int64 -> Bool -> Handler Html
 _setSelected bid selected = do
   userId <- requireAuthId
-  runDB $ do
+  runDB do
     let k_bid = BookmarkKey bid
     bm <- requireResource userId k_bid
     update k_bid [BookmarkSelected =. selected]

src/Handler/Notes.hs

@@ -18,7 +18,7 @@ getNotesR unamep@(UserNameP uname) = do
       page  = maybe 1  fromIntegral page'
       mqueryp = fmap (\q -> (queryp, q)) mquery
       isowner = maybe False (== uname) mauthuname
-  (bcount, notes) <- runDB $ do
+  (bcount, notes) <- runDB do
     Entity userId user <- getBy404 (UniqueUserName uname)
     let sharedp = if isowner then SharedAll else SharedPublic
     when (not isowner && userPrivacyLock user)
@@ -26,7 +26,7 @@ getNotesR unamep@(UserNameP uname) = do
     getNoteList userId mquery sharedp limit page
   req <- getRequest
   mroute <- getCurrentRoute
-  defaultLayout $ do
+  defaultLayout do
     rssLink (NotesFeedR unamep) "feed"
     let pager = $(widgetFile "pager")
         search = $(widgetFile "search")
@@ -54,7 +54,7 @@ getNoteR unamep@(UserNameP uname) slug = do
        when (not isowner && (userPrivacyLock user || (not . noteShared . entityVal) note))
          (redirect (AuthR LoginR))
        pure note
-  defaultLayout $ do
+  defaultLayout do
     $(widgetFile "note")
     toWidgetBody [julius|
         app.userR = "@{UserR unamep}";
@@ -70,7 +70,7 @@ getAddNoteViewR unamep@(UserNameP uname) = do
   userId <- requireAuthId
   let renderEl = "note" :: Text
   note <- liftIO $ Entity (NoteKey 0) <$> _toNote userId emptyNoteForm
-  defaultLayout $ do
+  defaultLayout do
     $(widgetFile "note")
     toWidgetBody [julius|
         app.userR = "@{UserR unamep}";
@@ -84,7 +84,7 @@ getAddNoteViewR unamep@(UserNameP uname) = do
 deleteDeleteNoteR :: Int64 -> Handler Html
 deleteDeleteNoteR nid = do
   userId <- requireAuthId
-  runDB $ do
+  runDB do
     let k_nid = NoteKey nid
     _ <- requireResource userId k_nid
     deleteCascade k_nid
@@ -168,7 +168,7 @@ getNotesFeedR unamep@(UserNameP uname) = do
   let limit = maybe 20 fromIntegral limit'
       page  = maybe 1   fromIntegral page'
       isowner = maybe False (== uname) mauthuname
-  (_, notes) <- runDB $ do
+  (_, notes) <- runDB do
       Entity userId user <- getBy404 (UniqueUserName uname)
       when (not isowner && userPrivacyLock user)
         (redirect (AuthR LoginR))

src/Handler/User.hs

@@ -52,7 +52,7 @@ _getUser unamep@(UserNameP uname) sharedp' filterp' (TagsP pathtags) = do
   mroute <- getCurrentRoute
   tagCloudMode <- getTagCloudMode isowner pathtags
   req <- getRequest
-  defaultLayout $ do
+  defaultLayout do
     let pager = $(widgetFile "pager")
         search = $(widgetFile "search")
         renderEl = "bookmarks" :: Text

src/Model.hs

@@ -173,12 +173,12 @@ bookmarksQuery userId sharedp filterp tags mquery limit' page =
   (,) -- total count
   <$> fmap (sum . fmap E.unValue)
       (select $
-      from $ \b -> do
+      from \b -> do
       _whereClause b
-      pure $ E.countRows)
+      pure E.countRows)
       -- paged data
   <*> (select $
-       from $ \b -> do
+       from \b -> do
        _whereClause b
        orderBy [desc (b ^. BookmarkTime)]
        limit limit'
@@ -189,7 +189,7 @@ bookmarksQuery userId sharedp filterp tags mquery limit' page =
       where_ $
         foldl (\expr tag ->
                 expr &&. (exists $   -- each tag becomes an exists constraint
-                          from $ \t ->
+                          from \t ->
                           where_ (t ^. BookmarkTagBookmarkId E.==. b ^. BookmarkId &&.
                                  (t ^. BookmarkTagTag `E.like` val tag))))
           (b ^. BookmarkUserId E.==. val userId)
@@ -261,7 +261,7 @@ parseTimeText t =
 tagsQuery :: [Entity Bookmark] -> DB [Entity BookmarkTag]
 tagsQuery bmarks =
   select $
-  from $ \t -> do
+  from \t -> do
   where_ (t ^. BookmarkTagBookmarkId `in_` valList (fmap entityKey bmarks))
   orderBy [asc (t ^. BookmarkTagSeq)]
   pure t
@@ -281,11 +281,11 @@ getNoteList key mquery sharedp limit' page =
   (,) -- total count
   <$> fmap (sum . fmap E.unValue)
       (select $
-      from $ \b -> do
+      from \b -> do
       _whereClause b
       pure $ E.countRows)
   <*> (select $
-       from $ \b -> do
+       from \b -> do
        _whereClause b
        orderBy [desc (b ^. NoteCreated)]
        limit limit'
@@ -471,7 +471,7 @@ allUserBookmarks user = do
     bquery :: DB [Entity Bookmark]
     bquery =
       select $
-      from $ \b -> do
+      from \b -> do
         where_ (b ^. BookmarkUserId E.==. val user)
         orderBy [asc (b ^. BookmarkTime)]
         pure b
@@ -479,7 +479,7 @@ allUserBookmarks user = do
     tquery =
       fmap (\(tid, tags) -> (E.unValue tid, E.unValue tags)) <$>
       (select $
-       from $ \t -> do
+       from \t -> do
          where_ (t ^. BookmarkTagUserId E.==. val user)
          E.groupBy (t ^. BookmarkTagBookmarkId)
          let tags = sqlite_group_concat (t ^. BookmarkTagTag) (E.val " ")
@@ -539,7 +539,7 @@ tagCountTop user top =
     sortOn (toLower . fst) .
     fmap (\(tname, tcount) -> (E.unValue tname, E.unValue tcount)) <$>
     ( select $
-      from $ \t -> do
+      from \t -> do
       where_ (t ^. BookmarkTagUserId E.==. val user)
       E.groupBy (E.lower_ $ t ^. BookmarkTagTag)
       let countRows' = E.countRows
@@ -552,7 +552,7 @@ tagCountLowerBound :: Key User -> Int -> DB [(Text, Int)]
 tagCountLowerBound user lowerBound = 
     fmap (\(tname, tcount) -> (E.unValue tname, E.unValue tcount)) <$>
     ( select $
-      from $ \t -> do
+      from \t -> do
       where_ (t ^. BookmarkTagUserId E.==. val user)
       E.groupBy (E.lower_ $ t ^. BookmarkTagTag)
       let countRows' = E.countRows
@@ -565,11 +565,11 @@ tagCountRelated :: Key User -> [Tag] -> DB [(Text, Int)]
 tagCountRelated user tags = 
     fmap (\(tname, tcount) -> (E.unValue tname, E.unValue tcount)) <$>
     ( select $
-      from $ \t -> do
+      from \t -> do
       where_ $
         foldl (\expr tag ->
                 expr &&. (exists $
-                          from $ \u ->
+                          from \u ->
                           where_ (u ^. BookmarkTagBookmarkId E.==. t ^. BookmarkTagBookmarkId &&.
                                  (u ^. BookmarkTagTag `E.like` val tag))))
           (t ^. BookmarkTagUserId E.==. val user)
@@ -704,7 +704,7 @@ _toBookmark userId BookmarkForm {..} = do
     }
 
 fetchBookmarkByUrl :: Key User -> Maybe Text -> DB (Maybe (Entity Bookmark, [Entity BookmarkTag]))
-fetchBookmarkByUrl userId murl = runMaybeT $ do
+fetchBookmarkByUrl userId murl = runMaybeT do
   bmark <- MaybeT . getBy . UniqueUserHref userId =<< (MaybeT $ pure murl)
   btags <- lift $ withTags (entityKey bmark)
   pure (bmark, btags)

src/Settings.hs

@@ -66,7 +66,7 @@ data AppSettings = AppSettings
     }
 
 instance FromJSON AppSettings where
-    parseJSON = withObject "AppSettings" $ \o -> do
+    parseJSON = withObject "AppSettings" \o -> do
         let defaultDev =
 #ifdef DEVELOPMENT
                 True