Fix PathPiece for ZIPArchiveName & submission original archive link

This commit is contained in:
Gregor Kleen 2018-07-10 13:47:02 +02:00
parent 86e28f6f52
commit 03a785abc2
2 changed files with 5 additions and 7 deletions

View File

@ -285,15 +285,12 @@ instance Default Theme where
derivePersistField "Theme" derivePersistField "Theme"
newtype ZIPArchiveName obj = ZIPArchiveName obj newtype ZIPArchiveName obj = ZIPArchiveName { unZIPArchiveName :: obj }
deriving (Show, Read, Eq) deriving (Show, Read, Eq)
instance PathPiece obj => PathPiece (ZIPArchiveName obj) where instance PathPiece obj => PathPiece (ZIPArchiveName obj) where
fromPathPiece (map CI.mk . unpack -> s) fromPathPiece = fmap ZIPArchiveName . fromPathPiece <=< (stripSuffix `on` CI.foldCase) ".zip"
| Just s' <- stripSuffix (map CI.mk ".zip") s = fromPathPiece . pack $ map CI.original s' toPathPiece = (<> ".zip") . toPathPiece . unZIPArchiveName
| otherwise = Nothing
toPathPiece (ZIPArchiveName obj) = toPathPiece obj <> ".zip"
newtype DateTimeFormat = DateTimeFormat { unDateTimeFormat :: String } newtype DateTimeFormat = DateTimeFormat { unDateTimeFormat :: String }
deriving (Eq, Ord, Read, Show, ToJSON, FromJSON, PersistField, PersistFieldSql) deriving (Eq, Ord, Read, Show, ToJSON, FromJSON, PersistField, PersistFieldSql)

View File

@ -1,7 +1,8 @@
$maybe cID <- mcid $maybe cID <- mcid
<section style="padding-bottom:1em; margin-bottom:1em; border-bottom:1px solid black;"> <section>
<h2> <h2>
<a href=@{CSubmissionR tid csh shn cID (SubArchiveR (ZIPArchiveName SubmissionCorrected))}>Archiv <a href=@{CSubmissionR tid csh shn cID (SubArchiveR (ZIPArchiveName SubmissionCorrected))}>Archiv
(<a href=@{CSubmissionR tid csh shn cID (SubArchiveR (ZIPArchiveName SubmissionOriginal))}>Original</a>)
$if not (null lastEdits) $if not (null lastEdits)
<h3>_{MsgLastEdits} <h3>_{MsgLastEdits}
<ul> <ul>