diff --git a/.cf-clearance b/.cf-clearance new file mode 100644 index 0000000..4bed7eb --- /dev/null +++ b/.cf-clearance @@ -0,0 +1 @@ +cf_clearance=96f0dfc0741239f896f9443f721c94c8fafa82b0-1595277120-GJDOCYQO diff --git a/espial.cabal b/espial.cabal index b460eb0..cc98474 100644 --- a/espial.cabal +++ b/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 diff --git a/package.yaml b/package.yaml index bc7993b..0478b0b 100644 --- a/package.yaml +++ b/package.yaml @@ -42,6 +42,7 @@ extra-source-files: default-extensions: - BangPatterns +- BlockArguments - CPP - ConstraintKinds - DataKinds diff --git a/src/Application.hs b/src/Application.hs index 43a735a..bed769a 100644 --- a/src/Application.hs +++ b/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_ (appEkgPort settings) $ \ekgPort -> +-- for_ (appEkgHost settings) \ekgHost -> +-- for_ (appEkgPort settings) \ekgPort -> -- EKG.forkServerWith -- (appMetrics foundation ^. MM.metricsStore) -- (encodeUtf8 ekgHost) diff --git a/src/Foundation.hs b/src/Foundation.hs index 0d2d56c..5394db5 100644 --- a/src/Foundation.hs +++ b/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) diff --git a/src/Handler/AccountSettings.hs b/src/Handler/AccountSettings.hs index c019170..be835b4 100644 --- a/src/Handler/AccountSettings.hs +++ b/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)}"; diff --git a/src/Handler/Add.hs b/src/Handler/Add.hs index a2ac1a7..32a1cf6 100644 --- a/src/Handler/Add.hs +++ b/src/Handler/Add.hs @@ -16,7 +16,7 @@ getAddViewR = do let renderEl = "addForm" :: Text - popupLayout $ do + popupLayout do toWidget [whamlet|
|] diff --git a/src/Handler/Archive.hs b/src/Handler/Archive.hs index 6fd0b0e..ec73f09 100644 --- a/src/Handler/Archive.hs +++ b/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 - -_archiveUserAgent :: ByteString -_archiveUserAgent = "espial" + if statusCode (responseStatus res) == 200 + then pure $ (,) <$> action <*> submitId + else pure $ Left $ "Invalid statusCode: " <> show (responseStatus res) + _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 "") 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 -buildSimpleRequest url = - NH.parseRequest_ url & \r -> - r {NH.requestHeaders = [("User-Agent", _archiveUserAgent)]} +_buildArchiveSubmitRequest :: (String, String) -> String -> Handler NH.Request +_buildArchiveSubmitRequest (action, submitId) href = do + req <- buildRequest ("POST " <> action) + 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) + diff --git a/src/Handler/Edit.hs b/src/Handler/Edit.hs index 9a72765..a2034c9 100644 --- a/src/Handler/Edit.hs +++ b/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] diff --git a/src/Handler/Notes.hs b/src/Handler/Notes.hs index 20a9d2a..fd7872d 100644 --- a/src/Handler/Notes.hs +++ b/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)) diff --git a/src/Handler/User.hs b/src/Handler/User.hs index 980a229..3ce12ff 100644 --- a/src/Handler/User.hs +++ b/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 diff --git a/src/Model.hs b/src/Model.hs index eede372..660d5e8 100644 --- a/src/Model.hs +++ b/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) diff --git a/src/Settings.hs b/src/Settings.hs index 5cd4c52..8021945 100644 --- a/src/Settings.hs +++ b/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