stack-all-0.3: src/Snapshots.hs

{-# LANGUAGE OverloadedStrings #-}

module Snapshots (
  getMajorVers,
  latestSnapshot
  )
where

import Control.Monad
import Data.Aeson
import qualified Data.ByteString.Lazy.Char8 as B
import Data.List.Extra
import qualified Data.HashMap.Strict as H
import qualified Data.Text as T
import Data.Time.Clock (diffUTCTime, getCurrentTime)
import Network.HTTP.Query
import SimpleCmd (error')
import System.Directory
import System.Environment.XDG.BaseDir
import System.FilePath

import MajorVer

excludedMajors :: [MajorVer]
excludedMajors = [LTS 15, LTS 7, LTS 3, LTS 0]

getMajorVers :: IO [MajorVer]
getMajorVers = do
  obj <- getSnapshots
  return $ reverse . sort $ map (readMajor . T.unpack) (H.keys obj \\ ["lts"]) \\ excludedMajors

latestSnapshot :: MajorVer -> IO (Maybe String)
latestSnapshot ver = do
  lookupKey (T.pack (showMajor ver)) <$> getSnapshots

-- FIXME handle network failure
getSnapshots :: IO Object
getSnapshots = do
  file <- getUserCacheFile "stack-all" "snapshots.json"
  exists <- doesFileExist file
  unless exists $ do
    putStrLn $ "Creating " ++ file ++ " ..."
    createDirectoryIfMissing True (takeDirectory file)
  recent <- do
    if exists then do
      ts <- getModificationTime file
      t <- getCurrentTime
      -- < 3 hours
      return $ diffUTCTime t ts < 10000
      else return False
  if recent
    then do
    eobj <- eitherDecode <$> B.readFile file
    case eobj of
      Left err -> error' err
      Right obj -> return obj
    else do
    obj <- webAPIQuery "http://haddock.stackage.org/snapshots.json" []
    B.writeFile file $ encode obj
    return obj