aboutsummaryrefslogtreecommitdiff
path: root/src/CabalHelper/Compiletime/Cabal.hs
blob: ef6de8cfed222038956ca4f303f5aafffbe0e051 (plain) (blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
-- cabal-helper: Simple interface to Cabal's configuration state
-- Copyright (C) 2018  Daniel Gröber <cabal-helper@dxld.at>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.

{-|
Module      : CabalHelper.Compiletime.Program.Cabal
Description : Cabal library source unpacking
License     : GPL-3
-}

{-# LANGUAGE DeriveFunctor, ViewPatterns, OverloadedStrings, CPP #-}

module CabalHelper.Compiletime.Cabal where

import Data.Char
import Control.Exception
import Data.List
import Data.Maybe
import Data.Time.Calendar
import Data.Time.Clock
import Data.Time.Clock.POSIX
import Data.Version
import System.Directory
import System.Exit
import System.FilePath
import System.IO
import Text.Printf

import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8

import CabalHelper.Compiletime.Types
import CabalHelper.Compiletime.Process
import CabalHelper.Shared.Common (replace, parseVer, parseVerMay, parsePkgIdBS, panicIO)

type UnpackedCabalVersion = CabalVersion' (CommitId, CabalSourceDir)
type ResolvedCabalVersion = CabalVersion' CommitId
type CabalVersion = CabalVersion' ()

unpackedToResolvedCabalVersion :: UnpackedCabalVersion -> ResolvedCabalVersion
unpackedToResolvedCabalVersion (CabalHEAD (commit, _)) = CabalHEAD commit
unpackedToResolvedCabalVersion (CabalVersion ver) = CabalVersion ver

-- | Cabal library version we're compiling the helper exe against.
data CabalVersion' a
    = CabalHEAD a
    | CabalVersion { cvVersion :: Version }
      deriving (Eq, Ord, Functor)

newtype CommitId = CommitId { unCommitId :: String }

showUnpackedCabalVersion :: UnpackedCabalVersion -> String
showUnpackedCabalVersion (CabalHEAD (commitid, _)) =
  "HEAD-" ++ unCommitId commitid
showUnpackedCabalVersion CabalVersion {cvVersion} =
  showVersion cvVersion

showResolvedCabalVersion :: ResolvedCabalVersion -> String
showResolvedCabalVersion (CabalHEAD commitid) =
  "HEAD-" ++ unCommitId commitid
showResolvedCabalVersion CabalVersion {cvVersion} =
  showVersion cvVersion

showCabalVersion :: CabalVersion -> String
showCabalVersion (CabalHEAD ()) =
  "HEAD"
showCabalVersion CabalVersion {cvVersion} =
  showVersion cvVersion

data CabalPatchDescription = CabalPatchDescription
  { cpdVersions      :: [Version]
  , cpdUnpackVariant :: UnpackCabalVariant
  , cpdPatchFn       :: FilePath -> IO ()
  }

nopCabalPatchDescription :: CabalPatchDescription
nopCabalPatchDescription =
  CabalPatchDescription [] LatestRevision (const (return ()))

patchyCabalVersions :: [CabalPatchDescription]
patchyCabalVersions = [
  let versions  = [ Version [1,18,1] [] ]
      variant   = Pristine
      patch     = fixArrayConstraint
  in CabalPatchDescription versions variant patch,

  let versions  = [ Version [1,18,0] [] ]
      variant   = Pristine
      patch dir = do
        fixArrayConstraint dir
        fixOrphanInstance dir
  in CabalPatchDescription versions variant patch,

  let versions  = [ Version [1,24,1,0] [] ]
      variant   = Pristine
      patch _   = return ()
  in CabalPatchDescription versions variant patch
  ]
 where
   fixArrayConstraint dir = do
     let cabalFile    = dir </> "Cabal.cabal"
         cabalFileTmp = cabalFile ++ ".tmp"

     cf <- readFile cabalFile
     writeFile cabalFileTmp $ replace "&& < 0.5" "&& < 0.6" cf
     renameFile cabalFileTmp cabalFile

   fixOrphanInstance dir = do
     let versionFile    = dir </> "Distribution/Version.hs"
         versionFileTmp = versionFile ++ ".tmp"

     let languagePragma =
           "{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}"
         languagePragmaCPP =
           "{-# LANGUAGE CPP, DeriveDataTypeable, StandaloneDeriving #-}"

         derivingDataVersion =
           "deriving instance Data Version"
         derivingDataVersionCPP = unlines [
             "#if __GLASGOW_HASKELL__ < 707",
             derivingDataVersion,
             "#endif"
           ]

     vf <- readFile versionFile
     writeFile versionFileTmp
       $ replace derivingDataVersion derivingDataVersionCPP
       $ replace languagePragma languagePragmaCPP vf

     renameFile versionFileTmp versionFile

unpackPatchedCabal :: Env => Version -> FilePath -> IO CabalSourceDir
unpackPatchedCabal cabalVer tmpdir = do
    res@(CabalSourceDir dir) <- unpackCabalHackage cabalVer tmpdir variant
    patch dir
    return res
  where
    CabalPatchDescription _ variant patch = fromMaybe nopCabalPatchDescription $
      find ((cabalVer `elem`) . cpdVersions) patchyCabalVersions

-- legacy, for `installCabalLib` v1
unpackCabalV1
  :: Env
  => UnpackedCabalVersion
  -> FilePath
  -> IO CabalSourceDir
unpackCabalV1 (CabalVersion ver) tmpdir = do
  csdir <- unpackPatchedCabal ver tmpdir
  return csdir
unpackCabalV1 (CabalHEAD (_commit, csdir)) _tmpdir =
  return csdir

unpackCabal :: Env => CabalVersion -> FilePath -> IO UnpackedCabalVersion
unpackCabal (CabalVersion ver) _tmpdir = do
  return $ CabalVersion ver
unpackCabal (CabalHEAD ()) tmpdir = do
  (commit, csdir) <- unpackCabalHEAD tmpdir
  return $ CabalHEAD (commit, csdir)

data UnpackCabalVariant = Pristine | LatestRevision
newtype CabalSourceDir = CabalSourceDir { unCabalSourceDir :: FilePath }
unpackCabalHackage
    :: (Verbose, Progs)
    => Version
    -> FilePath
    -> UnpackCabalVariant
    -> IO CabalSourceDir
unpackCabalHackage cabalVer tmpdir variant = do
  let cabal = "Cabal-" ++ showVersion cabalVer
      dir = tmpdir </> cabal
      variant_opts = case variant of Pristine -> [ "--pristine" ]; _ -> []
      args = [ "get", cabal ] ++ variant_opts
  callProcessStderr (Just tmpdir) [] (cabalProgram ?progs) args
  return $ CabalSourceDir dir

unpackCabalHEAD :: Env => FilePath -> IO (CommitId, CabalSourceDir)
unpackCabalHEAD tmpdir = do
  let dir = tmpdir </> "cabal-head.git"
      url = "https://github.com/haskell/cabal.git"
  callProcessStderr (Just "/") [] "git" [ "clone", "--depth=1", url, dir]
  callProcessStderr (Just (dir </> "Cabal")) [] "cabal"
    [ "act-as-setup", "--", "sdist"
    , "--output-directory=" ++ tmpdir </> "Cabal" ]
  commit <- takeWhile isHexDigit <$>
    readCreateProcess (proc "git" ["rev-parse", "HEAD"]){ cwd = Just dir } ""
  ts <-
    readCreateProcess (proc "git" [ "show", "-s", "--format=%ct", "HEAD" ])
      { cwd = Just dir } ""
  let ut = posixSecondsToUTCTime $ fromInteger (read ts)
      (y,m,d) = toGregorian $ utctDay ut
      sec = round $ utctDayTime ut
      datecode =
        read $ show y ++ printf "%02d" m ++ printf "%02d" d ++ printf "%05d" sec
      sec :: Int; datecode :: Int
  let cabal_file = tmpdir </> "Cabal/Cabal.cabal"
  cf0 <- readFile cabal_file
  let Just cf1 = replaceVersionDecl (setVersion datecode) cf0
  writeFile (cabal_file<.>"tmp") cf1
  renameFile (cabal_file<.>"tmp") cabal_file
  return (CommitId commit, CabalSourceDir $ tmpdir </> "Cabal")
  where
    -- If the released version of cabal has 4 components but we use only three
    -- theirs will always be larger than this one here. That's not really
    -- critical though.
    setVersion i (versionBranch -> mj:mi:_:_:[]) =
        Just $ makeVersion $ mj:mi:[i]
    setVersion _ v =
        error $ "unpackCabalHEAD.setVersion: Wrong version format" ++ show v

-- | Replace the version declaration in a cabal file
replaceVersionDecl :: (Version -> Maybe Version) -> String -> Maybe String
replaceVersionDecl ver_fn cf = let
  isVersionDecl ([],t) = "version:" `isPrefixOf` t
  isVersionDecl (i,t) = "\n" `isSuffixOf` i && "version:" `isPrefixOf` t
  Just (before_ver,m) = find isVersionDecl $ splits cf
  Just (ver_decl,after_ver)
    = find (\s -> case s of (_i,'\n':x:_) -> not $ isSpace x; _ -> False)
    $ filter (\(_i,t) -> "\n" `isPrefixOf` t)
    $ splits m
  Just vers0 = dropWhile isSpace <$> stripPrefix "version:" ver_decl
  (vers1,rest) = span (\c -> isDigit c || c == '.') vers0
  Just verp | all isSpace rest = parseVerMay $ vers1 in do
  new_ver <- ver_fn verp
  return $ concat
    [ before_ver, "version: ", showVersion new_ver, after_ver ]
  where
    splits xs = inits xs `zip` tails xs

resolveCabalVersion :: Verbose => CabalVersion -> IO ResolvedCabalVersion
resolveCabalVersion (CabalVersion ver) = return $ CabalVersion ver
resolveCabalVersion (CabalHEAD ()) = do
  out <- readProcess' "git"
    [ "ls-remote", "https://github.com/haskell/cabal.git", "-h", "master" ] ""
  let commit = takeWhile isHexDigit out
  return $ CabalHEAD $ CommitId commit

findCabalFile :: FilePath -> IO (Maybe FilePath)
findCabalFile pkgdir = do
    cfiles <- filter isCabalFile <$> getDirectoryContents pkgdir
    case cfiles of
      [] -> return Nothing
      [cfile] -> return $ Just $ pkgdir </> cfile
      _ -> panicIO $ "Multiple cabal-files found in directory '"
             ++pkgdir++"': " ++ show cfiles
  where
    isCabalFile :: FilePath -> Bool
    isCabalFile f = takeExtension' f == ".cabal"

    takeExtension' :: FilePath -> String
    takeExtension' p =
        if takeFileName p == takeExtension p
          then "" -- just ".cabal" is not a valid cabal file
          else takeExtension p

complainIfNoCabalFile :: FilePath -> Maybe FilePath -> IO FilePath
complainIfNoCabalFile _ (Just cabal_file) = return cabal_file
complainIfNoCabalFile pkgdir Nothing =
  panicIO $ "No cabal file found in package-dir: '"++pkgdir++"'"

bultinCabalVersion :: Version
bultinCabalVersion = parseVer VERSION_Cabal

readSetupConfigHeader :: FilePath -> IO (Maybe UnitHeader)
readSetupConfigHeader file = bracket (openFile file ReadMode) hClose $ \h -> do
  parseSetupHeader <$> BS.hGetLine h

parseSetupHeader :: BS.ByteString -> Maybe UnitHeader
parseSetupHeader header = case BS8.words header of
  ["Saved", "package", "config", "for", pkgId ,
   "written", "by", setupId,
   "using", compId]
    -> UnitHeader
       <$> parsePkgIdBS pkgId
       <*> parsePkgIdBS setupId
       <*> parsePkgIdBS compId
  _ -> Nothing