add host to useragent
This commit is contained in:
parent
26d43109dd
commit
1786cf558e
1
.cf-clearance
Normal file
1
.cf-clearance
Normal file
|
@ -0,0 +1 @@
|
|||
cf_clearance=96f0dfc0741239f896f9443f721c94c8fafa82b0-1595277120-GJDOCYQO
|
12
espial.cabal
12
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
|
||||
|
|
|
@ -42,6 +42,7 @@ extra-source-files:
|
|||
|
||||
default-extensions:
|
||||
- BangPatterns
|
||||
- BlockArguments
|
||||
- CPP
|
||||
- ConstraintKinds
|
||||
- DataKinds
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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)}";
|
||||
|
|
|
@ -16,7 +16,7 @@ getAddViewR = do
|
|||
|
||||
let renderEl = "addForm" :: Text
|
||||
|
||||
popupLayout $ do
|
||||
popupLayout do
|
||||
toWidget [whamlet|
|
||||
<div id="#{ renderEl }">
|
||||
|]
|
||||
|
|
|
@ -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 "<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
|
||||
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)
|
||||
|
||||
|
|
|
@ -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]
|
||||
|
|
|
@ -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))
|
||||
|
|
|
@ -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
|
||||
|
|
28
src/Model.hs
28
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)
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue