{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-}
module StackageToHackage.Stackage where
import StackageToHackage.Stackage.Types
import StackageToHackage.Stackage.YAML ()
import Control.Applicative ((<|>))
import Control.Monad.Extra (loopM, unlessM)
import Data.ByteString.Lazy (toStrict)
import Data.List (nub, foldl', find, (\\))
import Data.List.NonEmpty (NonEmpty(..), head, nonEmpty, reverse, (<|))
import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)
import Data.Semigroup
import Data.Text (Text, replace, unpack, isPrefixOf)
import Data.YAML (FromYAML, decodeStrict)
import Network.HTTP.Client (httpLbs, parseRequest, responseBody)
import Network.HTTP.Client.TLS (getGlobalManager)
import Prelude hiding (head, reverse, takeWhile)
import System.Directory
(XdgDirectory(..), createDirectoryIfMissing, doesFileExist, getXdgDirectory)
import System.FilePath (takeDirectory, (</>))
import System.IO (stderr, hPutStrLn)
import qualified Data.ByteString as BS
localDirs :: Stack -> NonEmpty FilePath
localDirs Stack { packages } = fromMaybe (pure ".") $ nonEmpty $ mapMaybe
locals
packages
where
locals (Local p) = Just p
locals (Location _) = Nothing
readStack :: BS.ByteString -> IO Stack
readStack text = either fail pure $ decode1Strict text
unroll :: FilePath -> Stack -> IO Resolvers
unroll base stack = do
let stack' = stack2resolver stack
reverse <$> loopM next (pure (Just base, stack'))
where
next :: RelativeResolvers -> IO (Either RelativeResolvers Resolvers)
next rs = case head rs of
(_, Resolver Nothing _ _ _) -> pure $ Right (snd <$> rs)
(dir, Resolver (Just r) _ _ _) -> Left . (<| rs) <$> resolve dir r
resolve :: Maybe FilePath -> ResolverRef -> IO (Maybe FilePath, Resolver)
resolve _ (Canned lts) = do
cached <- cache lts
text <- BS.readFile cached <|> download
update cached text
either fail (\r -> pure (Nothing, r)) $ new2old <$> decode1Strict text
where
download =
let path = unpack
$ replace "." "/" (replace "-" "/" (replace "-0" "-" lts))
raw = concat
[ "https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/"
, path, ".yaml"
]
in do
manager <- getGlobalManager
url <- parseRequest raw
hPutStrLn stderr ("Downloading: " <> raw)
resp <- httpLbs url manager
pure $ toStrict $ responseBody resp
update file content =
unlessM (doesFileExist file) (BS.writeFile file content)
resolve (Just base) (Snapshot path)
| isPrefixOf "http://" path || isPrefixOf "https://" path = parseFromURL
| otherwise = parseFromFile
where
parseFromFile = do
let file = base </> unpack path
dir = takeDirectory file
text <- BS.readFile file
either fail (\r -> pure (Just dir, r)) $ decode1Strict text
parseFromURL = do
text <- download
either fail (\r -> pure (Nothing, r)) $ decode1Strict text
download = do
manager <- getGlobalManager
url <- parseRequest (unpack path)
hPutStrLn stderr ("Downloading: " <> unpack path)
resp <- httpLbs url manager
pure $ toStrict $ responseBody resp
resolve Nothing _ = fail "Remote snapshots can't use relative paths."
cache :: Text -> IO FilePath
cache file = do
dir <- getXdgDirectory XdgCache "stackage"
createDirectoryIfMissing True dir
pure $ dir </> unpack file
stack2resolver :: Stack -> Resolver
stack2resolver Stack { resolver, compiler, packages, extraDeps, flags } =
Resolver (Just resolver) compiler (sourcedeps <> extraDeps) flags
where
sourcedeps = mapMaybe pick packages
pick (Local _) = Nothing
pick (Location g) = Just . SourceDep $ g
new2old :: NewResolver -> Resolver
new2old NewResolver { compiler, packages, flags } = Resolver
Nothing
(Just compiler)
(new2old' <$> packages)
flags
where new2old' (NewDep pkg) = Hackage pkg
mergeResolvers :: Resolver -> Resolver -> Resolver
mergeResolvers (Resolver r c p f) (Resolver r' c' p' f') =
Resolver (r <|> r') (c <|> c') (mergeDeps p p') (f <> f')
where
mergeDeps :: [Dep] -> [Dep] -> [Dep]
mergeDeps lhs rhs =
let nonGits = filter (not . isGitDep) lhs <> filter (not . isGitDep) rhs
gitsLhs = (\(SourceDep dep) -> dep) <$> filter isGitDep lhs
gitsRhs = (\(SourceDep dep) -> dep) <$> filter isGitDep rhs
gitMerged = foldl' (\m key -> update key m) gitsRhs gitsLhs
in (SourceDep <$> gitMerged) <> nonGits
update :: Git -> [Git] -> [Git]
update git xs =
case find (\g -> git { subdirs = [], commit = "" }
== g { subdirs = [], commit = "" })
xs of
Just g
| commit g == commit git
-> git { subdirs = nub (subdirs git <> subdirs g) }
: delete g xs
| otherwise
-> git
: g { subdirs = nub (subdirs g) \\ nub (subdirs git) }
: delete g xs
Nothing -> git : xs
isGitDep :: Dep -> Bool
isGitDep (SourceDep _) = True
isGitDep _ = False
delete :: Eq a => a -> [a] -> [a]
delete deleted xs = [ x | x <- xs, x /= deleted ]
decode1Strict :: FromYAML a => BS.ByteString -> Either String a
decode1Strict text = do
as <- case decodeStrict text of
Left e -> Left $ snd e
Right a -> Right a
maybe (Left "expected unique") Right $ listToMaybe as