diff --git a/Handler/Alias.hs b/Handler/Alias.hs index f0fb571..67ac7c2 100644 --- a/Handler/Alias.hs +++ b/Handler/Alias.hs @@ -1,7 +1,15 @@ -module Handler.Alias where +module Handler.Alias + ( handleAliasR + , getLtsR + , getNightlyR + ) where import Import import Data.Slug (Slug) +import Data.Text.Read (decimal) +import Handler.StackageHome (getStackageHomeR, getStackageMetadataR, getStackageCabalConfigR) +import Handler.StackageIndex (getStackageIndexR, getStackageBundleR) +import Handler.StackageSdist (getStackageSdistR) handleAliasR :: Slug -> Slug -> [Text] -> Handler () handleAliasR user name pieces = do @@ -13,3 +21,66 @@ handleAliasR user name pieces = do case parseRoute ("stackage" : toPathPiece setid : pieces, []) of Nothing -> notFound Just route -> redirect (route :: Route App) + +parseLtsPair :: Text -> Maybe (Int, Int) +parseLtsPair t1 = do + (x, t2) <- either (const Nothing) Just $ decimal t1 + t3 <- stripPrefix "." t2 + (y, "") <- either (const Nothing) Just $ decimal t3 + Just (x, y) + +getLtsR :: [Text] -> Handler () +getLtsR pieces0 = + case pieces0 of + [] -> go [] + piece:pieces' + | Just (x, y) <- parseLtsPair piece -> goXY x y pieces' + | Just x <- fromPathPiece piece -> goX x pieces' + | otherwise -> go pieces0 + where + go pieces = do + mlts <- runDB $ selectFirst [] [Desc LtsMajor, Desc LtsMinor] + case mlts of + Nothing -> notFound + Just (Entity _ (Lts _ _ sid)) -> goSid sid pieces + + goX x pieces = do + mlts <- runDB $ selectFirst [LtsMajor ==. x] [Desc LtsMinor] + case mlts of + Nothing -> notFound + Just (Entity _ (Lts _ _ sid)) -> goSid sid pieces + + goXY x y pieces = do + Entity _ (Lts _ _ sid) <- runDB $ getBy404 $ UniqueLts x y + goSid sid pieces + +getNightlyR :: [Text] -> Handler () +getNightlyR pieces0 = + case pieces0 of + [] -> go [] + piece:pieces' + | Just day <- fromPathPiece piece -> goDay day pieces' + | otherwise -> go pieces0 + where + go pieces = do + mn <- runDB $ selectFirst [] [Desc NightlyDay] + case mn of + Nothing -> notFound + Just (Entity _ (Nightly _ _ sid)) -> goSid sid pieces + goDay day pieces = do + Entity _ (Nightly _ _ sid) <- runDB $ getBy404 $ UniqueNightly day + goSid sid pieces + +goSid :: StackageId -> [Text] -> Handler () +goSid sid pieces = do + s <- runDB $ get404 sid + case parseRoute ("snapshot" : toPathPiece (stackageSlug s) : pieces, []) of + Just (SnapshotR slug sr) -> + case sr of + StackageHomeR -> getStackageHomeR slug >>= sendResponse + StackageMetadataR -> getStackageMetadataR slug >>= sendResponse + StackageCabalConfigR -> getStackageCabalConfigR slug >>= sendResponse + StackageIndexR -> getStackageIndexR slug >>= sendResponse + StackageBundleR -> getStackageBundleR slug >>= sendResponse + StackageSdistR pnv -> getStackageSdistR slug pnv >>= sendResponse + _ -> notFound diff --git a/Handler/Haddock.hs b/Handler/Haddock.hs index 799ff17..a8ef524 100644 --- a/Handler/Haddock.hs +++ b/Handler/Haddock.hs @@ -45,7 +45,7 @@ getUploadHaddockR slug0 = do master <- getYesod void $ liftIO $ forkIO $ haddockUnpacker master True ident setMessage "Haddocks uploaded" - redirect $ StackageHomeR slug + redirect $ SnapshotR slug StackageHomeR _ -> defaultLayout $ do setTitle "Upload Haddocks" $(widgetFile "upload-haddock") diff --git a/Handler/Home.hs b/Handler/Home.hs index 635890b..35344e6 100644 --- a/Handler/Home.hs +++ b/Handler/Home.hs @@ -53,11 +53,11 @@ getHomeR = do #{asHtml title} $maybe ex <- mex - exclusive + exclusive $if isJust mex && isJust min' $maybe in <- min' - inclusive + inclusive |] where name suffix = concat ["unstable-", short, "-", suffix] diff --git a/Handler/UploadStackage.hs b/Handler/UploadStackage.hs index 8e5a9d4..26ef97d 100644 --- a/Handler/UploadStackage.hs +++ b/Handler/UploadStackage.hs @@ -125,7 +125,7 @@ putUploadStackageR = do setAlias - done "Stackage created" $ StackageHomeR slug + done "Stackage created" $ SnapshotR slug StackageHomeR else do done "Error creating index file" ProfileR diff --git a/config/models b/config/models index 75ef561..0a8f918 100644 --- a/config/models +++ b/config/models @@ -99,3 +99,15 @@ BannedTag Migration num Int UniqueMigration num + +Nightly + day Day + ghcVersion Text + stackage StackageId + UniqueNightly day + +Lts + major Int + minor Int + stackage StackageId + UniqueLts major minor diff --git a/config/routes b/config/routes index 65e11a5..79a7ecd 100644 --- a/config/routes +++ b/config/routes @@ -15,12 +15,13 @@ /stackage/#PackageSetIdent/*Texts OldStackageR GET -/snapshot/#SnapSlug StackageHomeR GET -/snapshot/#SnapSlug/metadata StackageMetadataR GET -/snapshot/#SnapSlug/cabal.config StackageCabalConfigR GET -/snapshot/#SnapSlug/00-index.tar.gz StackageIndexR GET -/snapshot/#SnapSlug/bundle StackageBundleR GET -/snapshot/#SnapSlug/package/#PackageNameVersion StackageSdistR GET +/snapshot/#SnapSlug SnapshotR: + / StackageHomeR GET + /metadata StackageMetadataR GET + /cabal.config StackageCabalConfigR GET + /00-index.tar.gz StackageIndexR GET + /bundle StackageBundleR GET + /package/#PackageNameVersion StackageSdistR GET /hackage-view/#HackageView/00-index.tar.gz HackageViewIndexR GET /hackage-view/#HackageView/package/#PackageNameVersion HackageViewSdistR GET @@ -39,3 +40,6 @@ /tags TagListR GET /tag/#Slug TagR GET /banned-tags BannedTagsR GET PUT + +/lts/*Texts LtsR GET +/nightly/*Texts NightlyR GET diff --git a/templates/all-snapshots.hamlet b/templates/all-snapshots.hamlet index 7fafd1a..94de511 100644 --- a/templates/all-snapshots.hamlet +++ b/templates/all-snapshots.hamlet @@ -8,7 +8,7 @@ $forall (ident, title, _uploaded, display, handle) <- stackages
  • - + #{title}

    #{display} (#{handle}) diff --git a/templates/package.hamlet b/templates/package.hamlet index 3d61484..43048a7 100644 --- a/templates/package.hamlet +++ b/templates/package.hamlet @@ -131,7 +131,7 @@ $newline never #{version} - #{fromMaybe title $ stripSuffix ", exclusive" title} + #{fromMaybe title $ stripSuffix ", exclusive" title}

    diff --git a/templates/stackage-home.hamlet b/templates/stackage-home.hamlet index 3007ef2..2c4bbb7 100644 --- a/templates/stackage-home.hamlet +++ b/templates/stackage-home.hamlet @@ -7,15 +7,15 @@ $newline never $if hasBundle - + \Metadata - + \Bundle - + \cabal.config $if stackageHasHaddocks stackage @@ -28,7 +28,7 @@ $newline never .

    -            remote-repo: stackage-#{slug}:@{StackageHomeR slug}
    +            remote-repo: stackage-#{slug}:@{SnapshotR slug StackageHomeR}
         $maybe _ <- minclusive
             

    What's the difference between inclusive and exclusive snapshots? diff --git a/templates/upload-haddock.hamlet b/templates/upload-haddock.hamlet index addfcd5..1c26887 100644 --- a/templates/upload-haddock.hamlet +++ b/templates/upload-haddock.hamlet @@ -2,7 +2,7 @@

    Upload Haddocks

    - Return to snapshot + Return to snapshot $if stackageHasHaddocks