diff --git a/Handler/Download.hs b/Handler/Download.hs index 9d4d418..67caf94 100644 --- a/Handler/Download.hs +++ b/Handler/Download.hs @@ -10,6 +10,7 @@ import Import import Data.GhcLinks import Yesod.GitRepo (grContent) import Stackage.Database +import qualified Data.Text as T executableFor :: SupportedArch -> StackageExecutable executableFor Win32 = StackageWindowsExecutable @@ -36,30 +37,13 @@ getDownloadR = defaultLayout $ do setTitle "Download" $(widgetFile "download") -{- FIXME -ltsMajorVersions :: YesodDB App [Lts] -ltsMajorVersions = - (dropOldMinors . map entityVal) - <$> selectList [] [Desc LtsMajor, Desc LtsMinor] - -dropOldMinors :: [Lts] -> [Lts] -dropOldMinors [] = [] -dropOldMinors (l@(Lts x _ _):rest) = - l : dropOldMinors (dropWhile sameMinor rest) - where - sameMinor (Lts y _ _) = x == y --} - getDownloadSnapshotsJsonR :: Handler Value getDownloadSnapshotsJsonR = getDownloadLtsSnapshotsJsonR getDownloadLtsSnapshotsJsonR :: Handler Value getDownloadLtsSnapshotsJsonR = do - error "getDownloadLtsSnapshotsJsonR" - {- - (mlatestNightly, ltses) <- runDB $ (,) - <$> getLatestNightly - <*> ltsMajorVersions + mlatestNightly <- newestNightly + ltses <- ltsMajorVersions let lts = case ltses of [] -> [] majorVersions@(latest:_) -> @@ -70,31 +54,25 @@ getDownloadLtsSnapshotsJsonR = do Just n -> (("nightly" .= printNightly n):) return $ object $ nightly lts where - toObj lts@(Lts major _ _) = + toObj lts@(major, _) = pack ("lts-" ++ show major) .= printLts lts - printLts (Lts major minor _) = + printLts (major, minor) = "lts-" ++ show major ++ "." ++ show minor - printNightly (Entity _ (Nightly day _ _)) = - "nightly-" ++ tshow day - getLatestNightly = selectFirst [] [Desc NightlyDay] + printNightly day = "nightly-" ++ tshow day -- Print the ghc major version for the given snapshot. --- Assumes 7.8 if unspecified -ghcMajorVersionText :: Stackage -> Text -ghcMajorVersionText snapshot - = ghcMajorVersionToText - $ fromMaybe (GhcMajorVersion 7 8) - $ stackageGhcMajorVersion snapshot - -} +ghcMajorVersionText :: Snapshot -> Text +ghcMajorVersionText = + getMajorVersion . snapshotGhc + where + getMajorVersion :: Text -> Text + getMajorVersion = intercalate "." . take 2 . T.splitOn "." getGhcMajorVersionR :: SnapName -> Handler Text -getGhcMajorVersionR _slug = do - error "getGhcMajorVersionR" - {- - snapshot <- runDB $ getBy404 $ UniqueSnapshot slug - return $ ghcMajorVersionText $ entityVal snapshot - -} +getGhcMajorVersionR name = do + snapshot <- lookupSnapshot name >>= maybe notFound return + return $ ghcMajorVersionText $ entityVal snapshot getDownloadGhcLinksR :: SupportedArch -> Text -> Handler TypedContent getDownloadGhcLinksR arch fileName = do diff --git a/Stackage/Database.hs b/Stackage/Database.hs index 9682bd4..03cc086 100644 --- a/Stackage/Database.hs +++ b/Stackage/Database.hs @@ -5,6 +5,7 @@ module Stackage.Database , Snapshot (..) , newestLTS , newestLTSMajor + , ltsMajorVersions , newestNightly , lookupSnapshot , snapshotTitle @@ -401,6 +402,19 @@ newestLTSMajor :: GetStackageDatabase m => Int -> m (Maybe Int) newestLTSMajor x = run $ liftM (fmap $ ltsMinor . entityVal) $ selectFirst [LtsMajor ==. x] [Desc LtsMinor] +ltsMajorVersions :: GetStackageDatabase m => m [(Int, Int)] +ltsMajorVersions = + run $ liftM (dropOldMinors . map (toPair . entityVal)) + $ selectList [] [Desc LtsMajor, Desc LtsMinor] + where + toPair (Lts _ x y) = (x, y) + + dropOldMinors [] = [] + dropOldMinors (l@(x, _):rest) = + l : dropOldMinors (dropWhile sameMinor rest) + where + sameMinor (y, _) = x == y + newestNightly :: GetStackageDatabase m => m (Maybe Day) newestNightly = run $ liftM (fmap $ nightlyDay . entityVal) $ selectFirst [] [Desc NightlyDay]