cblrepo-0.14.0: src/PkgDB.hs

{-
 - Copyright 2011-2014 Per Magnus Therning
 -
 - Licensed under the Apache License, Version 2.0 (the "License");
 - you may not use this file except in compliance with the License.
 - You may obtain a copy of the License at
 -
 -     http://www.apache.org/licenses/LICENSE-2.0
 -
 - Unless required by applicable law or agreed to in writing, software
 - distributed under the License is distributed on an "AS IS" BASIS,
 - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 - See the License for the specific language governing permissions and
 - limitations under the License.
 -}

{-# LANGUAGE TemplateHaskell #-}

module PkgDB
    ( CblPkg
    , pkgName
    , pkgPkg
    , pkgVersion
    , pkgXRev
    , pkgDeps
    , pkgFlags
    , pkgRelease
    --
    , isGhcPkg
    , isDistroPkg
    , isRepoPkg
    , isBasePkg
    --
    , createGhcPkg
    , createDistroPkg
    , createRepoPkg
    , createCblPkg
    --
    , CblDB
    , addPkg
    , addPkg2
    , delPkg
    , bumpRelease
    , lookupPkg
    , transitiveDependants
    , checkDependants
    , checkAgainstDb
    , saveDb
    , readDb
    ) where

-- {{{1 imports
import Control.Arrow
import Control.Exception as CE
import Control.Monad
import Data.List
import Data.Maybe
import Distribution.PackageDescription
import System.IO.Error
import qualified Distribution.Package as P
import qualified Distribution.Version as V

import Data.Aeson (decode, encode)
import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..))
import qualified Data.ByteString.Lazy.Char8 as C

import qualified Util.Dist

-- {{{1 types
data Pkg
    = GhcPkg { version :: V.Version }
    | DistroPkg { version :: V.Version, release :: String }
    | RepoPkg { version :: V.Version, xrev :: Int, deps :: [P.Dependency], flags :: FlagAssignment, release :: String }
    deriving (Eq, Show)

data CblPkg = CP String Pkg
    deriving (Eq, Show)

type CblDB = [CblPkg]

instance Ord CblPkg where
    compare
        (CP n1 GhcPkg { version = v1 })
        (CP n2 GhcPkg { version = v2 }) =
            compare (n1, v1) (n2, v2)
    compare (CP _ GhcPkg {}) _ = LT
    compare _ (CP _ GhcPkg {}) = GT

    compare
        (CP n1 DistroPkg { version = v1, release = r1 })
        (CP n2 DistroPkg { version = v2, release = r2 }) =
            compare (n1, v1, r1) (n2, v2, r2)
    compare (CP _ DistroPkg {}) _ = LT
    compare _ (CP _ DistroPkg {}) = GT

    compare
        (CP n1 RepoPkg { version = v1, release = r1 })
        (CP n2 RepoPkg { version = v2, release = r2 }) =
            compare (n1, v1, r1) (n2, v2, r2)

-- {{{1 packages
pkgName :: CblPkg -> String
pkgName (CP n _) = n

pkgPkg :: CblPkg -> Pkg
pkgPkg (CP _ p) = p

pkgVersion :: CblPkg -> V.Version
pkgVersion (CP _ p) = version p

pkgXRev :: CblPkg -> Int
pkgXRev (CP _ RepoPkg { xrev = x }) = x
pkgXRev _ = 0

pkgDeps :: CblPkg -> [P.Dependency]
pkgDeps (CP _ RepoPkg { deps = d}) = d
pkgDeps _ = []

pkgFlags :: CblPkg -> FlagAssignment
pkgFlags (CP _ RepoPkg { flags = fa}) = fa
pkgFlags _ = []

pkgRelease :: CblPkg -> String
pkgRelease (CP _ GhcPkg {}) = "xx"
pkgRelease (CP _ DistroPkg { release = r }) = r
pkgRelease (CP _ RepoPkg { release = r }) = r

createGhcPkg :: String -> V.Version -> CblPkg
createGhcPkg n v = CP n (GhcPkg v)

createDistroPkg :: String -> V.Version -> String -> CblPkg
createDistroPkg n v r = CP n (DistroPkg v r)

createRepoPkg :: String -> V.Version -> Int -> [P.Dependency] -> FlagAssignment -> String -> CblPkg
createRepoPkg n v x d fa r = CP n (RepoPkg v x d fa r)

createCblPkg :: PackageDescription -> FlagAssignment -> CblPkg
createCblPkg pd fa = createRepoPkg name version xrev deps fa "1"
    where
        name = Util.Dist.pkgNameStr pd
        version = P.pkgVersion $ package pd
        xrev = Util.Dist.pkgXRev pd
        deps = buildDepends pd

getDependencyOn :: String -> CblPkg -> Maybe P.Dependency
getDependencyOn n p = find (\ d -> Util.Dist.depName d == n) (pkgDeps p)

isGhcPkg :: CblPkg -> Bool
isGhcPkg (CP _ GhcPkg {}) = True
isGhcPkg _ = False

isDistroPkg :: CblPkg -> Bool
isDistroPkg (CP _ DistroPkg {}) = True
isDistroPkg _ = False

isRepoPkg :: CblPkg -> Bool
isRepoPkg (CP _ RepoPkg {}) = True
isRepoPkg _ = False

isBasePkg :: CblPkg -> Bool
isBasePkg = not . isRepoPkg

-- {{{1 database
emptyPkgDB :: CblDB
emptyPkgDB = []

addPkg :: CblDB -> String -> Pkg -> CblDB
addPkg db n p = nubBy cmp newdb
    where
        cmp (CP n1 _) (CP n2 _) = n1 == n2
        newdb = CP n p:db

addPkg2 :: CblDB -> CblPkg -> CblDB
addPkg2 db (CP n p) = addPkg db n p

addGhcPkg :: CblDB -> String -> V.Version -> CblDB
addGhcPkg db n v = addPkg2 db (createGhcPkg n v)

addDistroPkg :: CblDB -> String -> V.Version -> String -> CblDB
addDistroPkg db n v r = addPkg2 db (createDistroPkg n v r)

delPkg :: CblDB -> String -> CblDB
delPkg db n = filter (\ p -> n /= pkgName p) db

bumpRelease :: CblDB -> String -> CblDB
bumpRelease db n = maybe db (addPkg2 db . doBump) (lookupPkg db n)
    where
        doBump (CP n' p@RepoPkg { release = r }) = CP n' (p { release = nr })
            where
                nr = show $ read r + (1 :: Int)
        doBump p = p

lookupPkg :: CblDB -> String -> Maybe CblPkg
lookupPkg [] _ = Nothing
lookupPkg (p:db) n
    | n == pkgName p = Just p
    | otherwise = lookupPkg db n

lookupDependants :: [CblPkg] -> String -> [String]
lookupDependants db n = filter (/= n) $ map pkgName $ filter (`doesDependOn` n) db
    where
        doesDependOn p n = n `elem` map Util.Dist.depName (pkgDeps p)

transitiveDependants :: CblDB -> [String] -> [String]
transitiveDependants db names = keepLast $ concatMap transUsersOfOne names
    where
        transUsersOfOne n = n : transitiveDependants db (lookupDependants db n)
        keepLast = reverse . nub . reverse

checkDependants :: CblDB -> String -> V.Version -> [(String, Maybe P.Dependency)]
checkDependants db n v = let
        d1 = mapMaybe (lookupPkg db) (lookupDependants db n)
        -- d2 = map (\ p -> (pkgName p, getDependencyOn n p)) d1
        d2 = map (pkgName &&& getDependencyOn n ) d1
        fails = filter (not . V.withinRange v . Util.Dist.depVersionRange . fromJust . snd) d2
    in fails

checkAgainstDb :: CblDB -> String -> P.Dependency -> Bool
checkAgainstDb db name dep = let
        dN = Util.Dist.depName dep
        dVR = Util.Dist.depVersionRange dep
    in (dN == name) ||
            (case lookupPkg db dN of
                Nothing -> False
                Just (CP _ p) -> V.withinRange (version p) dVR)

readDb :: FilePath -> IO CblDB
readDb fp = handle
    (\ e -> if isDoesNotExistError e
        then return emptyPkgDB
        else throwIO e)
    $ do
        r <- (mapM decode . C.lines) `liftM` C.readFile fp
        case r of
            Just a -> return a
            Nothing -> fail "JSON parsing failed"

saveDb :: CblDB -> FilePath -> IO ()
saveDb db fp = C.writeFile fp s
    where
        s = C.unlines $ map encode $ sort db

-- {{{1 JSON instances
$(deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField, allNullaryToStringTag = False } ''V.Version)
$(deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField, allNullaryToStringTag = False } ''V.VersionRange)
$(deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField, allNullaryToStringTag = False } ''P.Dependency)
$(deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField, allNullaryToStringTag = False } ''P.PackageName)
$(deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField, allNullaryToStringTag = False } ''FlagName)
$(deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField, allNullaryToStringTag = False } ''Pkg)
$(deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField, allNullaryToStringTag = False } ''CblPkg)