stackage-server/src/Handler/OldLinks.hs

{-# LANGUAGE NoImplicitPrelude #-}
module Handler.OldLinks
    ( getOldSnapshotBranchR
    , getOldSnapshotR
    ) where

import Import
import Stackage.Database
import qualified Data.Text.Read as Reader
import Network.Wai (rawQueryString)

data LtsSuffix = LSMajor !Int
               | LSMinor !Int !Int

parseLtsSuffix :: Text -> Maybe LtsSuffix
parseLtsSuffix t0 = do
        Right (x, t1) <- Just $ Reader.decimal t0
        if null t1
            then return $ LSMajor x
            else do
                t2 <- stripPrefix "." t1
                Right (y, "") <- Just $ Reader.decimal t2
                return $ LSMinor x y

redirectWithQueryText :: Text -> Handler a
redirectWithQueryText url = do
    req <- waiRequest
    redirect $ url ++ decodeUtf8 (rawQueryString req)

getOldSnapshotBranchR :: SnapshotBranch -> [Text] -> Handler ()
getOldSnapshotBranchR LtsBranch pieces = track "Handler.OldLinks.getOldSnapshotBranchR@LtsBranch" $ do
    (x, y, pieces') <- case pieces of
        t:ts | Just suffix <- parseLtsSuffix t -> do
            (x, y) <- case suffix of
                LSMajor x -> do
                    y <- newestLTSMajor x >>= maybe notFound return
                    return (x, y)
                LSMinor x y -> return (x, y)
            return (x, y, ts)
        _ -> do
            (x, y) <- newestLTS >>= maybe notFound return
            return (x, y, pieces)
    let name = concat ["lts-", tshow x, ".", tshow y]
    redirectWithQueryText $ concatMap (cons '/') $ name : pieces'

getOldSnapshotBranchR (LtsMajorBranch x) pieces = track "Handler.OldLinks.getOldSnapshotBranchR@LtsMajorBranch" $ do
    y <- newestLTSMajor x >>= maybe notFound return
    let name = concat ["lts-", tshow x, ".", tshow y]
    redirectWithQueryText $ concatMap (cons '/') $ name : pieces

getOldSnapshotBranchR NightlyBranch pieces = track "Handler.OldLinks.getOldSnapshotBranchR@NightlyBranch" $ do
    (day, pieces') <- case pieces of
        t:ts | Just day <- fromPathPiece t -> return (day, ts)
        _ -> do
            day <- newestNightly >>= maybe notFound return
            return (day, pieces)
    let name = "nightly-" ++ tshow day
    redirectWithQueryText $ concatMap (cons '/') $ name : pieces'

getOldSnapshotR :: Text -> [Text] -> Handler ()
getOldSnapshotR t ts = track "Handler.OldLinks.getOldSnapshotR" $
    case fromPathPiece t :: Maybe SnapName of
        Just _ -> redirectWithQueryText $ concatMap (cons '/') $ t : ts
        Nothing -> notFound