From 33338a73cce52f07afa774edeb5e83a238a0da8d Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Wed, 5 Dec 2018 03:41:19 +0000 Subject: [PATCH] Upgrade to GHC 8.4 and LTS 12 --- clone-deps.sh | 9 +- src/Data/CaseInsensitive/Local.hs | 4 +- src/Data/Git/Local.hs | 9 +- .../Persist/Local/Sql/Orphan/Common.hs | 5 - src/Vervis/Application.hs | 2 +- src/Vervis/Foundation.hs | 8 +- src/Vervis/Git.hs | 69 +++++++++----- src/Vervis/Handler/Home.hs | 11 +-- src/Yesod/Auth/Unverified.hs | 92 ++++++++----------- src/Yesod/Auth/Unverified/Creds.hs | 38 +------- src/Yesod/Auth/Unverified/Internal.hs | 6 +- src/Yesod/SessionEntity.hs | 2 +- stack.yaml | 17 +++- vervis.cabal | 11 +-- 14 files changed, 128 insertions(+), 155 deletions(-) diff --git a/clone-deps.sh b/clone-deps.sh index f3018b4..4538284 100644 --- a/clone-deps.sh +++ b/clone-deps.sh @@ -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 diff --git a/src/Data/CaseInsensitive/Local.hs b/src/Data/CaseInsensitive/Local.hs index 1d49e1a..e120338 100644 --- a/src/Data/CaseInsensitive/Local.hs +++ b/src/Data/CaseInsensitive/Local.hs @@ -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 diff --git a/src/Data/Git/Local.hs b/src/Data/Git/Local.hs index 558e090..e2b2f31 100644 --- a/src/Data/Git/Local.hs +++ b/src/Data/Git/Local.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016 by fr33domlover . + - Written in 2016, 2018 by fr33domlover . - - ♡ 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 diff --git a/src/Database/Persist/Local/Sql/Orphan/Common.hs b/src/Database/Persist/Local/Sql/Orphan/Common.hs index 562e557..e2529aa 100644 --- a/src/Database/Persist/Local/Sql/Orphan/Common.hs +++ b/src/Database/Persist/Local/Sql/Orphan/Common.hs @@ -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 diff --git a/src/Vervis/Application.hs b/src/Vervis/Application.hs index 84287bb..0da8805 100644 --- a/src/Vervis/Application.hs +++ b/src/Vervis/Application.hs @@ -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 diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 9ad8075..ab75686 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -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 diff --git a/src/Vervis/Git.hs b/src/Vervis/Git.hs index e9f4dc5..0cb5f14 100644 --- a/src/Vervis/Git.hs +++ b/src/Vervis/Git.hs @@ -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 diff --git a/src/Vervis/Handler/Home.hs b/src/Vervis/Handler/Home.hs index c43b201..9ab4a08 100644 --- a/src/Vervis/Handler/Home.hs +++ b/src/Vervis/Handler/Home.hs @@ -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!" diff --git a/src/Yesod/Auth/Unverified.hs b/src/Yesod/Auth/Unverified.hs index a046e90..50695f0 100644 --- a/src/Yesod/Auth/Unverified.hs +++ b/src/Yesod/Auth/Unverified.hs @@ -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 diff --git a/src/Yesod/Auth/Unverified/Creds.hs b/src/Yesod/Auth/Unverified/Creds.hs index 0e93c83..10c991c 100644 --- a/src/Yesod/Auth/Unverified/Creds.hs +++ b/src/Yesod/Auth/Unverified/Creds.hs @@ -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 diff --git a/src/Yesod/Auth/Unverified/Internal.hs b/src/Yesod/Auth/Unverified/Internal.hs index 0befc74..9ac77fb 100644 --- a/src/Yesod/Auth/Unverified/Internal.hs +++ b/src/Yesod/Auth/Unverified/Internal.hs @@ -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 diff --git a/src/Yesod/SessionEntity.hs b/src/Yesod/SessionEntity.hs index a3621be..63f9658 100644 --- a/src/Yesod/SessionEntity.hs +++ b/src/Yesod/SessionEntity.hs @@ -75,7 +75,7 @@ cachedRecord wrap unwrap = fmap unwrap . cached . fmap wrap - . liftHandlerT + . liftHandler . runDB . get diff --git a/stack.yaml b/stack.yaml index d410496..0b545c4 100644 --- a/stack.yaml +++ b/stack.yaml @@ -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: diff --git a/vervis.cabal b/vervis.cabal index 7bc4441..61430ac 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -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