This repository has been archived by the owner on Feb 3, 2020. It is now read-only.
-
Notifications
You must be signed in to change notification settings - Fork 11
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
Merge branch 'master' of https://github.com/vlatkoB/stackage-curator …
…into vlatkoB-master
- Loading branch information
Showing
3 changed files
with
175 additions
and
59 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -1,66 +1,161 @@ | ||
| {-# LANGUAGE OverloadedStrings, NoImplicitPrelude #-} | ||
| {-# LANGUAGE GADTs #-} | ||
| {-# LANGUAGE FlexibleContexts #-} | ||
| {-# LANGUAGE FlexibleContexts, GADTs, NoImplicitPrelude, OverloadedStrings, | ||
| ScopedTypeVariables #-} | ||
| module Stackage.DiffPlans | ||
| ( diffPlans | ||
| ) where | ||
|
|
||
| import Stackage.Prelude | ||
| import Data.Yaml (decodeFileEither) | ||
| import Data.Map (filterWithKey) | ||
| import Data.Text (Text, justifyLeft) | ||
| import qualified Data.Text as T | ||
| import Data.Yaml (decodeFileEither) | ||
| import qualified Distribution.Text as DT | ||
| import Network.HTTP.Client | ||
| import Network.HTTP.Client.TLS (tlsManagerSettings) | ||
| import Stackage.Prelude | ||
|
|
||
| import Data.Maybe | ||
| import Lucid | ||
| import System.Directory | ||
|
|
||
| data Change = Added | Deleted | MajorBump | MinorBump | Unchanged | ||
| deriving (Show, Eq, Ord) | ||
|
|
||
| data AndOr a = Old a | New a | Both a a | ||
| deriving Show | ||
| instance Semigroup (AndOr a) where | ||
| Old x <> New y = Both x y | ||
| New y <> Old x = Both x y | ||
| Old x <> Old _ = Old x | ||
| New x <> New _ = New x | ||
| Both x y <> _ = Both x y | ||
| Old x <> New y = Both x y | ||
| New y <> Old x = Both x y | ||
| Old x <> Old _ = Old x | ||
| New x <> New _ = New x | ||
| Both x y <> _ = Both x y | ||
|
|
||
| type DiffMap = Map Change (Map PackageName (Text,Maybe Text)) | ||
|
|
||
| diffPlans :: FilePath -- ^ old YAML build plan file | ||
| -> FilePath -- ^ new YAML build plan file | ||
| -> Bool -- ^ show just changed packages | ||
| -> Bool -- ^ use colours | ||
| -> Bool -- ^ fetch YAML files from GitHub repo | ||
| -> Bool -- ^ wrap output in HTML | ||
| -> IO () | ||
| diffPlans oldFP newFP = do | ||
| diffPlans oldFP newFP diffsOnly useColor True asHtml = do | ||
| (oldFP', newFP') <- (,) <$> getLTS (fpToString oldFP) <*> getLTS (fpToString newFP) | ||
| diffPlans oldFP' newFP' diffsOnly useColor False asHtml | ||
| delFile $ fpToString oldFP' | ||
| delFile $ fpToString newFP' | ||
|
|
||
| where | ||
| delFile fp = removeFile fp `catch` \(_::SomeException) -> return () | ||
|
|
||
| diffPlans oldFP newFP diffsOnly useColor False asHtml = do | ||
| old <- fmap Old <$> parse oldFP | ||
| new <- fmap New <$> parse newFP | ||
| let combined = unionWith (<>) old new | ||
| m :: Map Change (Map PackageName Text) | ||
| m = unionsWith mappend $ map go $ mapToList combined | ||
| m :: DiffMap | ||
| m = f . unionsWith mappend . map go $ mapToList combined | ||
| f = if diffsOnly | ||
| then filterWithKey (\k _ -> k /= Unchanged) | ||
| else id | ||
|
|
||
| forM_ (mapToList m) $ \(change, m') -> do | ||
| print change | ||
| forM_ (mapToList m') $ \(pkg, msg) -> do | ||
| putStrLn $ concat | ||
| [ display pkg | ||
| , ": " | ||
| , msg | ||
| ] | ||
| putStrLn "" | ||
| if asHtml | ||
| then print $ htmlOut True m | ||
| else consoleOut useColor m | ||
| where | ||
| parse fp = decodeFileEither (fpToString fp) | ||
| >>= either throwIO (return . toSimple) | ||
|
|
||
| toSimple = fmap ppVersion . bpPackages | ||
|
|
||
| go (name, Old x) = singletonMap Deleted $ singletonMap name $ display x | ||
| go (name, New x) = singletonMap Added $ singletonMap name $ display x | ||
| go (name, Old x) = singletonMap Deleted $ singletonMap name (display x, Nothing) | ||
| go (name, New x) = singletonMap Added $ singletonMap name (display x, Nothing) | ||
| go (name, Both x y) | ||
| | x == y = singletonMap Unchanged $ singletonMap name $ display x | ||
| | otherwise = singletonMap | ||
| (if isMajor x y then MajorBump else MinorBump) | ||
| (singletonMap name (concat | ||
| [ display x | ||
| , " ==> " | ||
| , display y | ||
| ])) | ||
| | x == y = singletonMap Unchanged $ singletonMap name (display x, Nothing) | ||
| | otherwise = singletonMap | ||
| (if isMajor x y then MajorBump else MinorBump) | ||
| (singletonMap name $ (display x, Just $ display y)) | ||
|
|
||
| isMajor :: Version -> Version -> Bool | ||
| isMajor (Version old _) (Version new _) = | ||
| toPair old /= toPair new | ||
| where | ||
| toPair [] = (0, 0) | ||
| toPair [i] = (i, 0) | ||
| toPair [] = (0, 0) | ||
| toPair [i] = (i, 0) | ||
| toPair (i:j:_) = (i, j) | ||
|
|
||
|
|
||
| -- | Download LTS file from GitHub to TMP dir | ||
| -- LTS should not contain extension nor path, i.e. just "lts-2.19" | ||
| getLTS :: String -> IO FilePath | ||
| getLTS lts = do | ||
| createDirectoryIfMissing True tmpDir | ||
| withManager tlsManagerSettings $ \man -> do | ||
| req <- parseUrl $ ltsRepo <> lts <> ".yaml" | ||
| res <- httpLbs req man | ||
| writeFile fName $ responseBody res | ||
| return fName | ||
| where | ||
| fName = fpFromString $ tmpDir <> lts <> ".yaml" | ||
| ltsRepo = "https://raw.githubusercontent.com/fpco/lts-haskell/master/" | ||
| tmpDir = "/tmp/stackage-curator/" | ||
|
|
||
|
|
||
| -- | Return coloured string, or html colour style, depending on *change* param | ||
| colorize :: Bool -> Change -> Text -> Text | ||
| colorize useHtml change s = | ||
| case change of | ||
| Deleted -> red s | ||
| Added -> green s | ||
| Unchanged -> s | ||
| MajorBump -> yellow s | ||
| MinorBump -> blue s | ||
| where | ||
| showInColor consCol htmlColor s | ||
| | useHtml = "color: " <> htmlColor | ||
| | otherwise = "\ESC[" <> consCol <> "m" <> s <> "\ESC[0m" | ||
|
|
||
| black = showInColor "30" "black" | ||
| red = showInColor "31" "red" | ||
| green = showInColor "32" "green" | ||
| yellow = showInColor "33" "yellow" | ||
| blue = showInColor "34" "blue" | ||
| magenta = showInColor "35" "magenta" | ||
| cyan = showInColor "36" "cyan" | ||
| white = showInColor "37" "white" | ||
|
|
||
|
|
||
| -- | Display to console | ||
| consoleOut :: Bool -> DiffMap -> IO () | ||
| consoleOut useColor m = | ||
| forM_ (mapToList m) $ \(change, m') -> do | ||
| print change | ||
| forM_ (mapToList m') $ \(pkg, (x,y)) -> | ||
| let pkgName = (if useColor then colorize False change else id) | ||
| $ justifyLeft 25 ' ' $ display pkg | ||
| in putStrLn $ pkgName <> | ||
| justifyLeft 9 ' ' x <> | ||
| if isJust y | ||
| then " => " <> fromJust y | ||
| else "" | ||
| putStrLn "" | ||
|
|
||
|
|
||
| -- | Display as HTML. If fullPage is True, display as complete page | ||
| htmlOut :: Bool -> DiffMap -> Html () | ||
| htmlOut fullPage m = do | ||
| when fullPage $ | ||
| doctypehtml_$ head_ $ do | ||
| meta_ [charset_ "utf-8"] | ||
| style_ "table, th, td {border : 1px solid black; border-collapse: collapse;}\ | ||
| \th, td {padding: 5px; text-align: left;}" | ||
| body_ $ | ||
| div_ [class_ "ltsDiffs"] $ do | ||
| h3_ "Differences" | ||
| forM_ (mapToList m) $ \(change, m') -> do | ||
| p_ [style_ $ colorize True change ""] $ toHtml $ show change | ||
| table_ $ forM_ (mapToList m') $ \(pkg, (x,y)) -> | ||
| tr_ $ do | ||
| td_ $ toHtml $ display pkg | ||
| td_ $ toHtml $ x | ||
| when (isJust y) $ | ||
| td_ $ toHtml $ fromJust y | ||
| br_ [] |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters