sup39/vervis
1
0
Fork 0
mirror of https://code.sup39.dev/repos/Wqawg synced 2024-12-27 17:04:52 +09:00
Code Issues Activity

Upgrade to GHC 8.4 and LTS 12

Browse source
This commit is contained in:
fr33domlover 2018-12-05 03:41:19 +00:00
parent 4c17e3486b
commit 33338a73cc
14 changed files with 128 additions and 155 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

9
clone-deps.sh
View file

@ -1,17 +1,16 @@
#!/bin/sh
VERVIS='https://dev.angeley.es/s/fr33domlover/r'
HUB='https://hub.darcs.net/fr33domlover'
mkdir -p lib
cd lib
darcs clone $HUB/hit-graph
darcs clone $HUB/hit-harder
darcs clone $HUB/hit-network
darcs clone $VERVIS/hit-graph
darcs clone $VERVIS/hit-harder
darcs clone $VERVIS/hit-network
darcs clone $VERVIS/darcs-lights
darcs clone $VERVIS/darcs-rev
darcs clone $VERVIS/ssh
darcs clone $VERVIS/persistent-migration
darcs clone $VERVIS/persistent-email-address
darcs clone $VERVIS/time-interval-aeson
darcs clone $VERVIS/yesod-mail-send --to-hash 2800294a41daf57cd420710bc79c8c9b06c0d3dd
darcs clone $VERVIS/yesod-mail-send

4
src/Data/CaseInsensitive/Local.hs
View file

@ -36,13 +36,13 @@ import Data.Hashable (Hashable)
import Data.String (IsString)
newtype AsOriginal s = AsOriginal { unOriginal :: CI s }
deriving (Eq, Ord, Read, Show, IsString, Monoid, Hashable, FoldCase)
deriving (Eq, Ord, Read, Show, IsString, Semigroup, Hashable, FoldCase)
mkOrig :: FoldCase s => s -> AsOriginal s
mkOrig = AsOriginal . mk
newtype AsCaseFolded s = AsCaseFolded { unCaseFolded :: CI s }
deriving (Eq, Ord, Read, Show, IsString, Monoid, Hashable, FoldCase)
deriving (Eq, Ord, Read, Show, IsString, Semigroup, Hashable, FoldCase)
mkFolded :: FoldCase s => s -> AsCaseFolded s
mkFolded = AsCaseFolded . mk

9
src/Data/Git/Local.hs
View file

@ -1,6 +1,6 @@
{- This file is part of Vervis.
-
- Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
- Written in 2016, 2018 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ Copying is an act of love. Please copy, reuse and share.
-
@ -33,6 +33,7 @@ import Control.Monad (when)
import Data.Byteable (toBytes)
import Data.Git
import Data.Git.Harder
import Data.Git.Ref (SHA1)
import Data.Git.Types (GitTime (..))
import Data.Set (Set)
import Data.Text (Text)
@ -104,7 +105,7 @@ data PathView
| TreeView Text ObjId TreeRows
| BlobView Text ObjId BL.ByteString
viewPath :: Git -> Tree -> EntPath -> IO PathView
viewPath :: Git SHA1 -> Tree SHA1 -> EntPath -> IO PathView
viewPath git root path = do
let toEnt False = EntObjBlob
toEnt True = EntObjTree
@ -122,8 +123,8 @@ viewPath git root path = do
Left blob -> return $ BlobView nameT oid (blobGetContent blob)
Right tree -> TreeView nameT oid <$> mkRows tree
listBranches :: Git -> IO (Set Text)
listBranches :: Git SHA1 -> IO (Set Text)
listBranches git = S.mapMonotonic (T.pack . refNameRaw) <$> branchList git
listTags :: Git -> IO (Set Text)
listTags :: Git SHA1 -> IO (Set Text)
listTags git = S.mapMonotonic (T.pack . refNameRaw) <$> tagList git

5
src/Database/Persist/Local/Sql/Orphan/Common.hs
View file

@ -13,7 +13,6 @@ module Database.Persist.Local.Sql.Orphan.Common
( fieldName
, dummyFromFilts
, getFiltsValues
, updatePersistValue
, filterClause
, orderClause
)
@ -203,10 +202,6 @@ filterClauseHelper includeTable includeWhere conn orNull filters =
showSqlFilter NotIn = " NOT IN "
showSqlFilter (BackendSpecificFilter s) = s
updatePersistValue :: Update v -> PersistValue
updatePersistValue (Update _ v _) = toPersistValue v
updatePersistValue _ = error "BackendUpdate not implemented"
filterClause :: (PersistEntity val, PersistEntityBackend val ~ SqlBackend)
=> Bool -- ^ include table name?
-> SqlBackend

2
src/Vervis/Application.hs
View file

@ -102,7 +102,7 @@ makeFoundation appSettings = do
appSvgFont <-
if appLoadFontFromLibData appSettings
then return lin2
then lin2
else loadFont "data/LinLibertineCut.svg"
-- We need a log function to create a connection pool. We need a connection

8
src/Vervis/Foundation.hs
View file

@ -386,7 +386,7 @@ instance Yesod App where
-- What messages should be logged. The following includes all messages when
-- in development, and warnings and errors in production.
shouldLog app _source level =
shouldLogIO app _source level = pure $
appShouldLogAll (appSettings app)
|| level == LevelWarn
|| level == LevelError
@ -433,7 +433,7 @@ instance YesodAuth App where
-- Override the above two destinations when a Referer: header is present
redirectToReferer _ = True
authenticate creds = do
authenticate creds = liftHandler $ do
let ident = credsIdent creds
mpid <- runDB $ getBy $ UniquePersonLogin $ credsIdent creds
return $ case mpid of
@ -443,7 +443,7 @@ instance YesodAuth App where
-- You can add other plugins like BrowserID, email or OAuth here
authPlugins _ = [accountPlugin]
authHttpManager = getHttpManager
authHttpManager = getsYesod getHttpManager
onLogout = clearUnverifiedCreds False
@ -517,7 +517,7 @@ instance YesodAuthAccount AccountPersistDB' App where
allowLoginByEmailAddress _ = True
runAccountDB = unAccountPersistDB'
unregisteredLogin u = do
lift $ setUnverifiedCreds True $ Creds "account" (username u) []
setUnverifiedCreds True $ Creds "account" (username u) []
return mempty
-- This instance is required to use forms. You can modify renderMessage to

69
src/Vervis/Git.hs
View file

@ -18,24 +18,27 @@ module Vervis.Git
, readChangesView
, listRefs
, readPatch
, lastCommitTime
)
where
import Prelude
import Control.Arrow ((***))
import Control.Monad (join)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except
import Data.Algorithm.Patience (diff, Item (..))
import Data.Byteable (toBytes)
import Data.Foldable (find)
import Data.Git
import Data.Foldable (foldlM, find)
import Data.Git.Diff
import Data.Git.Graph
import Data.Git.Harder
import Data.Git.Ref (fromHex, toHex)
import Data.Git.Repository (getCommit)
import Data.Git.Monad
import Data.Git.Ref (SHA1, fromHex, toHex)
import Data.Git.Storage (getObject_)
import Data.Git.Storage.Object (Object (..))
import Data.Git.Types (GitTime (..))
import Data.Git.Types (GitTime (..), ModePerm (..), EntPath, Blob (..))
import Data.Graph.Inductive.Graph (noNodes)
import Data.Graph.Inductive.Query.Topsort
import Data.List.NonEmpty (NonEmpty ((:|)))
@ -43,7 +46,8 @@ import Data.Set (Set)
import Data.String (fromString)
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Data.Time.Clock ()
import Data.Time.Calendar (Day (..))
import Data.Time.Clock (UTCTime (..))
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Data.Traversable (for)
import Data.Word (Word32)
@ -54,8 +58,9 @@ import Time.Types (Elapsed (..), Seconds (..))
import qualified Data.ByteString as B (intercalate)
import qualified Data.ByteString.Lazy as BL (ByteString, toStrict, length)
import qualified Data.DList as D (DList, empty, snoc, toList)
import qualified Data.Git as G
import qualified Data.List.NonEmpty as N (toList)
import qualified Data.Set as S (member, mapMonotonic)
import qualified Data.Set as S (member, mapMonotonic, toList)
import qualified Data.Text as T (pack, unpack, break, strip)
import qualified Data.Text.Encoding as TE (decodeUtf8With)
import qualified Data.Text.Encoding.Error as TE (lenientDecode)
@ -77,7 +82,7 @@ matchReadme _ = False
-- | Find a README file in a directory. Return the filename and the file
-- content.
findReadme :: Git -> TreeRows -> IO (Maybe (Text, BL.ByteString))
findReadme :: Git SHA1 -> TreeRows -> IO (Maybe (Text, BL.ByteString))
findReadme git rows =
case find matchReadme rows of
Nothing -> return Nothing
@ -95,23 +100,23 @@ rowToEntry :: (ModePerm, ObjId, Text, EntObjType) -> DirEntry
rowToEntry (_, _, name, etype) = DirEntry (matchType etype) name
loadSourceView
:: Git
:: Git SHA1
-> Text
-> [Text]
-> IO (Set RefName, Set RefName, Maybe (SourceView BL.ByteString))
loadSourceView git refT dir = do
branches <- branchList git
tags <- tagList git
branches <- G.branchList git
tags <- G.tagList git
let refS = T.unpack refT
refN = RefName refS
msv <- if refN `S.member` branches || refN `S.member` tags
then do
tipOid <- resolveName git refS
mtree <- resolveTreeish git $ unObjId tipOid
mtree <- G.resolveTreeish git $ unObjId tipOid
case mtree of
Nothing -> return Nothing
Just tree -> do
let dir' = map (entName . encodeUtf8) dir
let dir' = map (G.entName . encodeUtf8) dir
view <- viewPath git tree dir'
Just <$> case view of
RootView rows -> do
@ -140,7 +145,7 @@ readSourceView
-- ^ Branches, tags, view of the selected item
readSourceView path ref dir = do
(bs, ts, msv) <-
withRepo (fromString path) $ \ git -> loadSourceView git ref dir
G.withRepo (fromString path) $ \ git -> loadSourceView git ref dir
let toTexts = S.mapMonotonic $ T.pack . refNameRaw
return (toTexts bs, toTexts ts, renderSources dir <$> msv)
@ -159,7 +164,7 @@ readChangesView
-- ^ Limit, i.e. how many latest commits to take after the offset
-> IO (Int, [LogEntry])
-- ^ Total number of ref's changes, and view of selected ref's change log
readChangesView path ref off lim = withRepo (fromString path) $ \ git -> do
readChangesView path ref off lim = G.withRepo (fromString path) $ \ git -> do
oid <- resolveName git $ T.unpack ref
graph <- loadCommitGraphPT git [oid]
let mnodes = topsortUnmixOrder graph (NodeStack [noNodes graph])
@ -187,10 +192,10 @@ readChangesView path ref off lim = withRepo (fromString path) $ \ git -> do
return (noNodes graph, map (uncurry mkrow) pairs')
listRefs :: FilePath -> IO (Set Text, Set Text)
listRefs path = withRepo (fromString path) $ \ git ->
listRefs path = G.withRepo (fromString path) $ \ git ->
(,) <$> listBranches git <*> listTags git
patch :: [Edit] -> Commit -> Patch
patch :: [Edit] -> Commit SHA1 -> Patch
patch edits c = Patch
{ patchAuthorName = decodeUtf8 $ personName $ commitAuthor c
, patchAuthorEmail =
@ -251,7 +256,7 @@ mkdiff old new =
map eitherOldNew $
diff (zipWith Line [1..] old) (zipWith Line [1..] new)
accumEdits :: BlobStateDiff -> [Edit] -> [Edit]
accumEdits :: BlobStateDiff SHA1 -> [Edit] -> [Edit]
accumEdits (OnlyOld bs) es =
case bsContent bs of
FileContent lines -> RemoveTextFile (ep2fp $ bsFilename bs) (unModePerm $ bsMode bs) (map (decodeUtf8 . BL.toStrict) lines) : es
@ -277,14 +282,36 @@ accumEdits (OldAndNew old new) es =
else error "getDiffWith gave OldAndNew with different file paths"
readPatch :: FilePath -> Text -> IO (Patch, [Text])
readPatch path hash = withRepo (fromString path) $ \ git -> do
readPatch path hash = G.withRepo (fromString path) $ \ git -> do
let ref = fromHex $ encodeUtf8 hash
c <- getCommit git ref
c <- G.getCommit git ref
medits <- case commitParents c of
[] -> error "Use the tree to generate list of AddFile diff parts?"
[p] -> Right <$> getDiffWith accumEdits [] p ref git
ps -> fmap Left $ for ps $ \ p ->
decodeUtf8 . takeLine . commitMessage <$> getCommit git p
decodeUtf8 . takeLine . commitMessage <$> G.getCommit git p
return $ case medits of
Left parents -> (patch [] c, parents)
Right edits -> (patch edits c, [])
lastCommitTime :: FilePath -> IO (Maybe UTCTime)
lastCommitTime repo =
(either fail return =<<) $ fmap join $ withRepo (fromString repo) $ runExceptT $ do
branches <- S.toList <$> lift branchList
lct <- foldlM' utc0 branches $ \ time branch -> do
mcommit <- lift $ getCommit branch
case mcommit of
Nothing ->
throwE $
"lastCommitTime: Failed to get commit for branch " ++
refNameRaw branch
Just c ->
return $ max time $
utc $ gitTimeUTC $ personTime $ commitCommitter c
return $ if null branches
then Nothing
else Just lct
where
utc (Elapsed (Seconds i)) = posixSecondsToUTCTime $ fromIntegral i
utc0 = UTCTime (ModifiedJulianDay 0) 0
foldlM' i l f = foldlM f i l

11
src/Vervis/Handler/Home.hs
View file

@ -34,7 +34,7 @@ import Vervis.Model.Repo
import Vervis.Path
import Data.EventTime.Local
import qualified Vervis.GitOld as G
import qualified Vervis.Git as G
import qualified Vervis.Darcs as D
intro :: Handler Html
@ -56,20 +56,19 @@ intro = do
, repo ^. RepoVcs
)
now <- liftIO getCurrentTime
let utc (Seconds i) = posixSecondsToUTCTime $ fromIntegral i
forM repos $
\ (Value sharer, Value mproj, Value repo, Value vcs) -> do
path <- askRepoDir sharer repo
mlast <- case vcs of
VCSDarcs -> liftIO $ D.lastChange path now
VCSGit -> do
mel <- liftIO $ G.lastChange path
return $ Just $ case mel of
mt <- liftIO $ G.lastCommitTime path
return $ Just $ case mt of
Nothing -> Never
Just (Elapsed t) ->
Just t ->
intervalToEventTime $
FriendlyConvert $
now `diffUTCTime` utc t
now `diffUTCTime` t
return (sharer, mproj, repo, vcs, mlast)
defaultLayout $ do
setTitle "Welcome to Vervis!"

92
src/Yesod/Auth/Unverified.hs
View file

@ -120,11 +120,10 @@ maybeUnverifiedAuth
maybeUnverifiedAuth =
maybeEntity unverifiedLoginKey CachedUnverifiedLogin unCachedUnverifiedLogin
-- TODO fix signatures when moving to GHC 8
maybeAuthIdAllowUnverified
:: ( -- MonadHandler m
-- , HandlerSite m ~ master
YesodPersist master
:: ( MonadHandler m
, HandlerSite m ~ master
, YesodPersist master
, YesodPersistBackend master ~ backend
, PersistStoreRead backend
, YesodAuth master
@ -132,16 +131,15 @@ maybeAuthIdAllowUnverified
, PersistRecordBackend record backend
, Typeable record
)
-- => m (Maybe (Key record, Bool))
=> HandlerT master IO (Maybe (Key record, Bool))
=> m (Maybe (Key record, Bool))
maybeAuthIdAllowUnverified = runMaybeT $
(, True) <$> MaybeT maybeVerifiedAuthId
<|> (, False) <$> MaybeT maybeUnverifiedAuthId
maybeAuthAllowUnverified
:: ( -- MonadHandler m
-- , HandlerSite m ~ master
YesodPersist master
:: ( MonadHandler m
, HandlerSite m ~ master
, YesodPersist master
, YesodPersistBackend master ~ backend
, PersistStoreRead backend
, YesodAuthPersist master
@ -150,25 +148,20 @@ maybeAuthAllowUnverified
, PersistRecordBackend record backend
, Typeable record
)
-- => m (Maybe (Entity record, Bool))
=> HandlerT master IO (Maybe (Entity record, Bool))
=> m (Maybe (Entity record, Bool))
maybeAuthAllowUnverified = runMaybeT $
(, True) <$> MaybeT maybeVerifiedAuth
<|> (, False) <$> MaybeT maybeUnverifiedAuth
maybeVerifiedAuthId
{-
:: ( MonadHandler m
, HandlerSite m ~ master
, YesodAuth master
)
=> m (Maybe (AuthId master))
-}
:: YesodAuth master => HandlerT master IO (Maybe (AuthId master))
maybeVerifiedAuthId = maybeAuthId
maybeVerifiedAuth
{-
:: ( MonadHandler m
, HandlerSite m ~ master
, YesodAuthPersist master
@ -178,14 +171,6 @@ maybeVerifiedAuth
, Typeable record
)
=> m (Maybe (Entity record))
-}
:: ( YesodAuthPersist master
, AuthId master ~ Key record
, AuthEntity master ~ record
, PersistEntity record
, Typeable record
)
=> HandlerT master IO (Maybe (Entity record))
maybeVerifiedAuth = maybeAuth
handleAuthLack :: (YesodAuth (HandlerSite m), MonadHandler m) => m a
@ -201,7 +186,8 @@ handleAuthLack = do
Nothing -> permissionDenied "Please configure authRoute"
handleUnverified
:: YesodAuthVerify master => (a, Bool) -> HandlerT master IO a
:: (MonadHandler m, YesodAuthVerify (HandlerSite m))
=> (a, Bool) -> m a
handleUnverified (v, True) = return v
handleUnverified (_v, False) = do
aj <- acceptsJson
@ -213,7 +199,9 @@ handleUnverified (_v, False) = do
when (redirectToCurrent y) setUltDestCurrent
redirect $ verificationRoute y
handleVerified :: YesodAuth master => (a, Bool) -> HandlerT master IO a
handleVerified
:: (MonadHandler m, YesodAuth (HandlerSite m))
=> (a, Bool) -> m a
handleVerified (v, False) = return v
handleVerified (_v, True) = do
aj <- acceptsJson
@ -230,9 +218,9 @@ handleVerified (_v, True) = do
-- @since 1.1.0
requireUnverifiedAuthId
:: ( -- MonadHandler m
-- , HandlerSite m ~ master
YesodPersist master
:: ( MonadHandler m
, HandlerSite m ~ master
, YesodPersist master
, YesodPersistBackend master ~ backend
, PersistStoreRead backend
, YesodAuth master
@ -240,8 +228,7 @@ requireUnverifiedAuthId
, PersistRecordBackend record backend
, Typeable record
)
-- => m (Key record)
=> HandlerT master IO (Key record)
=> m (Key record)
requireUnverifiedAuthId =
maybeAuthIdAllowUnverified >>= maybe handleAuthLack handleVerified
@ -251,9 +238,9 @@ requireUnverifiedAuthId =
-- @since 1.1.0
requireUnverifiedAuth
:: ( -- MonadHandler m
-- , HandlerSite m ~ master
YesodPersist master
:: ( MonadHandler m
, HandlerSite m ~ master
, YesodPersist master
, YesodPersistBackend master ~ backend
, PersistStoreRead backend
, YesodAuthPersist master
@ -262,15 +249,14 @@ requireUnverifiedAuth
, PersistRecordBackend record backend
, Typeable record
)
-- => m (Entity record)
=> HandlerT master IO (Entity record)
=> m (Entity record)
requireUnverifiedAuth =
maybeAuthAllowUnverified >>= maybe handleAuthLack handleVerified
requireAuthIdAllowUnverified
:: ( -- MonadHandler m
-- , HandlerSite m ~ master
YesodPersist master
:: ( MonadHandler m
, HandlerSite m ~ master
, YesodPersist master
, YesodPersistBackend master ~ backend
, PersistStoreRead backend
, YesodAuth master
@ -278,15 +264,14 @@ requireAuthIdAllowUnverified
, PersistRecordBackend record backend
, Typeable record
)
-- => m (Key record, Bool)
=> HandlerT master IO (Key record, Bool)
=> m (Key record, Bool)
requireAuthIdAllowUnverified =
maybeAuthIdAllowUnverified >>= maybe handleAuthLack return
requireAuthAllowUnverified
:: ( -- MonadHandler m
-- , HandlerSite m ~ master
YesodPersist master
:: ( MonadHandler m
, HandlerSite m ~ master
, YesodPersist master
, YesodPersistBackend master ~ backend
, PersistStoreRead backend
, YesodAuthPersist master
@ -295,15 +280,14 @@ requireAuthAllowUnverified
, PersistRecordBackend record backend
, Typeable record
)
-- => m (Entity record, Bool)
=> HandlerT master IO (Entity record, Bool)
=> m (Entity record, Bool)
requireAuthAllowUnverified =
maybeAuthAllowUnverified >>= maybe handleAuthLack return
requireVerifiedAuthId
:: ( -- MonadHandler m
-- , HandlerSite m ~ master
YesodPersist master
:: ( MonadHandler m
, HandlerSite m ~ master
, YesodPersist master
, YesodPersistBackend master ~ backend
, PersistStoreRead backend
, YesodAuthVerify master
@ -311,15 +295,14 @@ requireVerifiedAuthId
, PersistRecordBackend record backend
, Typeable record
)
-- => m (Key record)
=> HandlerT master IO (Key record)
=> m (Key record)
requireVerifiedAuthId =
maybeAuthIdAllowUnverified >>= maybe handleAuthLack handleUnverified
requireVerifiedAuth
:: ( -- MonadHandler m
-- , HandlerSite m ~ master
YesodPersist master
:: ( MonadHandler m
, HandlerSite m ~ master
, YesodPersist master
, YesodPersistBackend master ~ backend
, PersistStoreRead backend
, YesodAuthPersist master
@ -329,7 +312,6 @@ requireVerifiedAuth
, PersistRecordBackend record backend
, Typeable record
)
-- => m (Entity record)
=> HandlerT master IO (Entity record)
=> m (Entity record)
requireVerifiedAuth =
maybeAuthAllowUnverified >>= maybe handleAuthLack handleUnverified

38
src/Yesod/Auth/Unverified/Creds.hs
View file

@ -113,7 +113,6 @@ import Yesod.Auth.Unverified.Internal
credsKey = unverifiedLoginKey
{-
loginErrorMessageI
:: Route Auth
-> AuthMessage
@ -121,16 +120,7 @@ loginErrorMessageI
loginErrorMessageI dest msg = do
toParent <- getRouteToParent
loginErrorMessageMasterI (toParent dest) msg
-}
loginErrorMessageI :: (MonadResourceBase m, YesodAuth master)
=> Route child
-> AuthMessage
-> HandlerT child (HandlerT master m) TypedContent
loginErrorMessageI dest msg = do
toParent <- getRouteToParent
lift $ loginErrorMessageMasterI (toParent dest) msg
{-
loginErrorMessageMasterI
:: (MonadHandler m, HandlerSite m ~ master, YesodAuth master)
=> Route master
@ -139,14 +129,6 @@ loginErrorMessageMasterI
loginErrorMessageMasterI dest msg = do
mr <- getMessageRender
loginErrorMessage dest (mr msg)
-}
loginErrorMessageMasterI :: (YesodAuth master, MonadResourceBase m, RenderMessage master AuthMessage)
=> Route master
-> AuthMessage
-> HandlerT master m TypedContent
loginErrorMessageMasterI dest msg = do
mr <- getMessageRender
loginErrorMessage dest (mr msg)
{-
-- | For HTML, set the message and redirect to the route.
@ -189,15 +171,10 @@ provideJsonMessage :: Monad m => Text -> Writer.Writer (Endo [ProvidedRep m]) ()
provideJsonMessage msg = provideRep $ return $ object ["message" .= msg]
-}
{-
setUnverifiedCredsRedirect
:: (MonadHandler m, YesodAuth (HandlerSite m))
:: (MonadHandler m, YesodAuthVerify (HandlerSite m))
=> Creds (HandlerSite m) -- ^ new credentials
-> m TypedContent
-}
setUnverifiedCredsRedirect :: YesodAuthVerify master
=> Creds master -- ^ new credentials
-> HandlerT master IO TypedContent
setUnverifiedCredsRedirect creds = do
y <- getYesod
auth <- authenticate creds
@ -236,16 +213,10 @@ setUnverifiedCredsRedirect creds = do
return $ renderAuthMessage master langs msg
-- | Sets user credentials for the session after checking them with authentication backends.
{-
setUnverifiedCreds :: (MonadHandler m, YesodAuth (HandlerSite m))
setUnverifiedCreds :: (MonadHandler m, YesodAuthVerify (HandlerSite m))
=> Bool -- ^ if HTTP redirects should be done
-> Creds (HandlerSite m) -- ^ new credentials
-> m ()
-}
setUnverifiedCreds :: YesodAuthVerify master
=> Bool -- ^ if HTTP redirects should be done
-> Creds master -- ^ new credentials
-> HandlerT master IO ()
setUnverifiedCreds doRedirects creds =
if doRedirects
then void $ setUnverifiedCredsRedirect creds
@ -269,14 +240,9 @@ authLayoutJson w json = selectRep $ do
-- | Clears current user credentials for the session.
--
-- @since 1.1.7
{-
clearUnverifiedCreds :: (MonadHandler m, YesodAuth (HandlerSite m))
=> Bool -- ^ if HTTP redirect to 'logoutDest' should be done
-> m ()
-}
clearUnverifiedCreds :: YesodAuth master
=> Bool -- ^ if HTTP redirect to 'logoutDest' should be done
-> HandlerT master IO ()
clearUnverifiedCreds doRedirects = do
y <- getYesod
-- onLogout

6
src/Yesod/Auth/Unverified/Internal.hs
View file

@ -26,8 +26,7 @@ import Prelude
import Data.Text (Text)
import Yesod.Auth (YesodAuth (..))
import Yesod.Core (Route)
import Yesod.Core.Handler (HandlerT)
import Yesod.Core (MonadHandler (..), Route)
class YesodAuth site => YesodAuthVerify site where
@ -43,8 +42,7 @@ class YesodAuth site => YesodAuthVerify site where
unverifiedLoginDest = verificationRoute
-- | Called on a successful unverified login. Default: 'onLogin'
--onUnverifiedLogin :: (MonadHandler m, site ~ HandlerSite m) => m ()
onUnverifiedLogin :: HandlerT site IO ()
onUnverifiedLogin :: (MonadHandler m, site ~ HandlerSite m) => m ()
onUnverifiedLogin = onLogin
-- | Session key used to hold the ID of the unverified logged-in user

2
src/Yesod/SessionEntity.hs
View file

@ -75,7 +75,7 @@ cachedRecord wrap unwrap
= fmap unwrap
. cached
. fmap wrap
. liftHandlerT
. liftHandler
. runDB
. get

17
stack.yaml
View file

@ -3,10 +3,14 @@
# Specifies the GHC version and set of packages available (e.g., lts-3.5,
# nightly-2015-09-21, ghc-7.10.2)
resolver: lts-10.10
resolver: lts-12.20
# Local packages, usually specified by relative directory name
packages:
- location:
git: https://github.com/bitemyapp/esqueleto.git
commit: 434f81ed41795e3dd0754dbc5c75c4ed098631b3
extra-dep: true
- .
- lib/darcs-lights
- lib/darcs-rev
@ -20,23 +24,26 @@ packages:
# - lib/yesod-auth-account
- location:
git: https://dev.angeley.es/s/fr33domlover/r/yesod-auth-account
commit: cc9d6a5d4e0d5fb3b061a5a9ccc0ab03eea89811
commit: c14795264c3d63b2126e91e98107a631405cea74
extra-dep: true
- lib/yesod-mail-send
# Packages to be pulled from upstream that are not in the resolver (e.g.,
# acme-missiles-0.3)
extra-deps:
- darcs-2.14.0
- SimpleAES-0.4.2
- data-default-instances-bytestring-0.0.1
- git-0.2.2
- highlighter2-0.2.5
- libravatar-0.4.0.2
- monad-hash-0.1.0.2
- monadcryptorandom-0.7.2.1
- patience-0.1.1
- persistent-parser-0.1.0.2
- SimpleAES-0.4.2
- RSA-2.2.0
- pwstore-fast-2.4.4
- time-interval-0.1.1
- time-units-1.0.0
- url-2.1.3
# Override default flag values for local packages and extra-deps
flags:

11
vervis.cabal
View file

@ -125,7 +125,6 @@ library
Vervis.Formatting
Vervis.Foundation
Vervis.Git
Vervis.GitOld
Vervis.GraphProxy
Vervis.Handler.Common
Vervis.Handler.Discussion
@ -256,13 +255,13 @@ library
, hashable
-- for source file highlighting
, highlighter2
, hit
, hit-graph >= 0.1
, hit-harder >= 0.1
, hit-network >= 0.1
, git
, hit-graph
, hit-harder
, hit-network
-- currently discarding all JS so no need for minifier
--, hjsmin
-- 'hit' uses it for 'GitTime'
-- 'git' uses it for 'GitTime'
, hourglass
, http-conduit
, http-types