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}
#{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
- 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
You have already uploaded Haddocks. Uploading again will delete the old contents.