module Stack.Types.Resolver
(Resolver
,IsLoaded(..)
,LoadedResolver
,ResolverWith(..)
,parseResolverText
,AbstractResolver(..)
,readAbstractResolver
,resolverRawName
,SnapName(..)
,Snapshots (..)
,renderSnapName
,parseSnapName
,SnapshotHash
,trimmedSnapshotHash
,snapshotHashToBS
,snapshotHashFromBS
,snapshotHashFromDigest
,parseCustomLocation
) where
import Crypto.Hash as Hash (hash, Digest, SHA256)
import Data.Aeson.Extended
(ToJSON, toJSON, FromJSON, parseJSON,
withObject, (.:), withText)
import qualified Data.ByteString as B
import qualified Data.ByteString.Base64.URL as B64URL
import qualified Data.HashMap.Strict as HashMap
import qualified Data.IntMap.Strict as IntMap
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8)
import Data.Text.Read (decimal)
import Data.Time (Day)
import Network.HTTP.Client (Request, parseUrlThrow)
import Options.Applicative (ReadM)
import qualified Options.Applicative.Types as OA
import Path
import Stack.Prelude
import Stack.Types.Compiler
import Stack.Types.PackageIdentifier
import qualified System.FilePath as FP
data IsLoaded = Loaded | NotLoaded
type LoadedResolver = ResolverWith SnapshotHash
type Resolver = ResolverWith (Either Request FilePath)
data ResolverWith customContents
= ResolverSnapshot !SnapName
| ResolverCompiler !(CompilerVersion 'CVWanted)
| ResolverCustom !Text !customContents
deriving (Generic, Typeable, Show, Data, Eq, Functor, Foldable, Traversable)
instance Store LoadedResolver
instance NFData LoadedResolver
instance ToJSON (ResolverWith a) where
toJSON x = case x of
ResolverSnapshot name -> toJSON $ renderSnapName name
ResolverCompiler version -> toJSON $ compilerVersionText version
ResolverCustom loc _ -> toJSON loc
instance a ~ () => FromJSON (ResolverWith a) where
parseJSON = withText "ResolverWith ()" $ return . parseResolverText
resolverRawName :: ResolverWith a -> Text
resolverRawName (ResolverSnapshot name) = renderSnapName name
resolverRawName (ResolverCompiler v) = compilerVersionText v
resolverRawName (ResolverCustom loc _ ) = "custom: " <> loc
parseCustomLocation
:: MonadThrow m
=> Maybe (Path Abs Dir)
-> ResolverWith ()
-> m Resolver
parseCustomLocation mdir (ResolverCustom t ()) =
ResolverCustom t <$> case parseUrlThrow $ T.unpack t of
Nothing -> Right <$> do
dir <-
case mdir of
Nothing -> throwM $ FilepathInDownloadedSnapshot t
Just x -> return x
let rel =
T.unpack
$ fromMaybe t
$ T.stripPrefix "file://" t <|> T.stripPrefix "file:" t
return $ toFilePath dir FP.</> rel
Just req -> return $ Left req
parseCustomLocation _ (ResolverSnapshot name) = return $ ResolverSnapshot name
parseCustomLocation _ (ResolverCompiler cv) = return $ ResolverCompiler cv
parseResolverText :: Text -> ResolverWith ()
parseResolverText t
| Right x <- parseSnapName t = ResolverSnapshot x
| Just v <- parseCompilerVersion t = ResolverCompiler v
| otherwise = ResolverCustom t ()
data AbstractResolver
= ARLatestNightly
| ARLatestLTS
| ARLatestLTSMajor !Int
| ARResolver !(ResolverWith ())
| ARGlobal
deriving Show
readAbstractResolver :: ReadM AbstractResolver
readAbstractResolver = do
s <- OA.readerAsk
case s of
"global" -> return ARGlobal
"nightly" -> return ARLatestNightly
"lts" -> return ARLatestLTS
'l':'t':'s':'-':x | Right (x', "") <- decimal $ T.pack x ->
return $ ARLatestLTSMajor x'
_ -> return $ ARResolver $ parseResolverText $ T.pack s
data SnapName
= LTS !Int !Int
| Nightly !Day
deriving (Generic, Typeable, Show, Data, Eq)
instance Store SnapName
instance NFData SnapName
data BuildPlanTypesException
= ParseSnapNameException !Text
| ParseResolverException !Text
| FilepathInDownloadedSnapshot !Text
deriving Typeable
instance Exception BuildPlanTypesException
instance Show BuildPlanTypesException where
show (ParseSnapNameException t) = "Invalid snapshot name: " ++ T.unpack t
show (ParseResolverException t) = concat
[ "Invalid resolver value: "
, T.unpack t
, ". Possible valid values include lts-2.12, nightly-YYYY-MM-DD, ghc-7.10.2, and ghcjs-0.1.0_ghc-7.10.2. "
, "See https://www.stackage.org/snapshots for a complete list."
]
show (FilepathInDownloadedSnapshot url) = unlines
[ "Downloaded snapshot specified a 'resolver: { location: filepath }' "
, "field, but filepaths are not allowed in downloaded snapshots.\n"
, "Filepath specified: " ++ T.unpack url
]
renderSnapName :: SnapName -> Text
renderSnapName (LTS x y) = T.pack $ concat ["lts-", show x, ".", show y]
renderSnapName (Nightly d) = T.pack $ "nightly-" ++ show d
parseSnapName :: MonadThrow m => Text -> m SnapName
parseSnapName t0 =
case lts <|> nightly of
Nothing -> throwM $ ParseSnapNameException t0
Just sn -> return sn
where
lts = do
t1 <- T.stripPrefix "lts-" t0
Right (x, t2) <- Just $ decimal t1
t3 <- T.stripPrefix "." t2
Right (y, "") <- Just $ decimal t3
return $ LTS x y
nightly = do
t1 <- T.stripPrefix "nightly-" t0
Nightly <$> readMaybe (T.unpack t1)
data Snapshots = Snapshots
{ snapshotsNightly :: !Day
, snapshotsLts :: !(IntMap Int)
}
deriving Show
instance FromJSON Snapshots where
parseJSON = withObject "Snapshots" $ \o -> Snapshots
<$> (o .: "nightly" >>= parseNightly)
<*> fmap IntMap.unions (mapM (parseLTS . snd)
$ filter (isLTS . fst)
$ HashMap.toList o)
where
parseNightly t =
case parseSnapName t of
Left e -> fail $ show e
Right (LTS _ _) -> fail "Unexpected LTS value"
Right (Nightly d) -> return d
isLTS = ("lts-" `T.isPrefixOf`)
parseLTS = withText "LTS" $ \t ->
case parseSnapName t of
Left e -> fail $ show e
Right (LTS x y) -> return $ IntMap.singleton x y
Right (Nightly _) -> fail "Unexpected nightly value"
newtype SnapshotHash = SnapshotHash { unSnapshotHash :: StaticSHA256 }
deriving (Generic, Typeable, Show, Data, Eq)
instance Store SnapshotHash
instance NFData SnapshotHash
trimmedSnapshotHash :: SnapshotHash -> Text
trimmedSnapshotHash = decodeUtf8 . B.take 12 . B64URL.encode . staticSHA256ToRaw . unSnapshotHash
snapshotHashToBS :: SnapshotHash -> ByteString
snapshotHashToBS = staticSHA256ToRaw . unSnapshotHash
snapshotHashFromBS :: ByteString -> SnapshotHash
snapshotHashFromBS = snapshotHashFromDigest . Hash.hash
snapshotHashFromDigest :: Digest SHA256 -> SnapshotHash
snapshotHashFromDigest = SnapshotHash . mkStaticSHA256FromDigest