git.iko.soy/stackage
on 982bcfa help sign in
stackage/Stackage/ServerBundle.hs
271 lines 9.2 kB history raw
1-- | Create a bundle to be uploaded to Stackage Server.
2{-# LANGUAGE NoImplicitPrelude #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE RecordWildCards #-}
5module Stackage.ServerBundle
6 ( serverBundle
7 , epochTime
8 , bpAllPackages
9 , docsListing
10 , createBundleV2
11 , CreateBundleV2 (..)
12 , SnapshotType (..)
13 , writeIndexStyle
14 , DocMap
15 , PackageDocs (..)
16 ) where
18import qualified Codec.Archive.Tar as Tar
19import qualified Codec.Archive.Tar.Entry as Tar
20import qualified Codec.Compression.GZip as GZip
21import qualified Data.Map as M
22import Data.Aeson (ToJSON (..), (.=), object, FromJSON (..), (.:), withObject)
23import System.IO.Temp (withTempDirectory)
24import qualified Data.Yaml as Y
25import Filesystem (isFile, getWorkingDirectory, listDirectory, isDirectory, canonicalizePath)
26import Foreign.C.Types (CTime (CTime))
27import Stackage.BuildConstraints
28import Stackage.BuildPlan
29import Stackage.Prelude
30import System.IO.Temp (withTempDirectory)
31import qualified System.PosixCompat.Time as PC
32import qualified Text.XML as X
33import Text.XML.Cursor
34import System.PosixCompat.Files (createSymbolicLink)
36-- | Get current time
37epochTime :: IO Tar.EpochTime
38epochTime = (\(CTime t) -> fromIntegral t) <$> PC.epochTime
40-- | All package/versions in a build plan, including core packages.
41--
42-- Note that this may include packages not available on Hackage.
43bpAllPackages :: BuildPlan -> Map PackageName Version
44bpAllPackages BuildPlan {..} =
45 siCorePackages bpSystemInfo ++ map ppVersion bpPackages
47serverBundle :: Tar.EpochTime
48 -> Text -- ^ title
49 -> Text -- ^ slug
50 -> BuildPlan
51 -> LByteString
52serverBundle time title slug bp@BuildPlan {..} = GZip.compress $ Tar.write
53 [ fe "build-plan.yaml" (fromStrict $ Y.encode bp)
54 , fe "hackage" hackage
55 , fe "slug" (fromStrict $ encodeUtf8 slug)
56 , fe "desc" (fromStrict $ encodeUtf8 title)
57 , fe "core" corePackagesList
58 ]
59 where
60 fe name contents =
61 case Tar.toTarPath False name of
62 Left s -> error s
63 Right name' -> (Tar.fileEntry name' contents)
64 { Tar.entryTime = time
65 }
66 hackage = builderToLazy $ foldMap goPair $ mapToList packageMap
68 -- need to remove some packages that don't exist on Hackage
69 packageMap = foldr deleteMap (bpAllPackages bp) $ map PackageName
70 [ "bin-package-db"
71 , "ghc"
72 , "rts"
73 ]
75 goPair (name, version) =
76 toBuilder (display name) ++
77 toBuilder (asText "-") ++
78 toBuilder (display version) ++
79 toBuilder (asText "\n")
81 corePackagesList =
82 builderToLazy $ toBuilder $ unlines $
83 map (\(PackageName name) -> name)
84 (M.keys $ siCorePackages bpSystemInfo)
86-- | Package name is key
87type DocMap = Map Text PackageDocs
88data PackageDocs = PackageDocs
89 { pdVersion :: Text
90 , pdModules :: Map Text [Text]
91 -- ^ module name, path
92 }
93instance ToJSON PackageDocs where
94 toJSON PackageDocs {..} = object
95 [ "version" .= pdVersion
96 , "modules" .= pdModules
97 ]
98instance FromJSON PackageDocs where
99 parseJSON = withObject "PackageDocs" $ \o -> PackageDocs
100 <$> o .: "version"
101 <*> o .: "modules"
103docsListing :: BuildPlan
104 -> FilePath -- ^ docs directory
105 -> IO DocMap
106docsListing bp docsDir =
107 fmap fold $ mapM go $ mapToList $ bpAllPackages bp
108 where
109 go :: (PackageName, Version) -> IO DocMap
110 go (package, version) = do -- handleAny (const $ return mempty) $ do
111 let dirname = fpFromText (concat
112 [ display package
113 , "-"
114 , display version
115 ])
116 indexFP = (docsDir </> dirname </> "index.html")
117 ie <- isFile indexFP
118 if ie
119 then do
120 doc <- flip X.readFile indexFP X.def
121 { X.psDecodeEntities = X.decodeHtmlEntities
122 }
123 let cursor = fromDocument doc
124 getPair x = take 1 $ do
125 href <- attribute "href" x
126 let name = concat $ x $// content
127 guard $ not $ null name
128 return (href, name)
129 pairs = cursor $// attributeIs "class" "module"
130 &/ laxElement "a" >=> getPair
131 m <- fmap fold $ forM pairs $ \(href, name) -> do
132 let suffix = dirname </> fpFromText href
133 e <- isFile $ docsDir </> suffix
134 return $ if e
135 then asMap $ singletonMap name [fpToText dirname, href]
136 else mempty
137 return $ singletonMap (display package) $ PackageDocs
138 { pdVersion = display version
139 , pdModules = m
140 }
141 else return mempty
143data SnapshotType = STNightly
144 | STLTS !Int !Int -- ^ major, minor
145 deriving (Show, Read, Eq, Ord)
147instance ToJSON SnapshotType where
148 toJSON STNightly = object
149 [ "type" .= asText "nightly"
150 ]
151 toJSON (STLTS major minor) = object
152 [ "type" .= asText "lts"
153 , "major" .= major
154 , "minor" .= minor
155 ]
156instance FromJSON SnapshotType where
157 parseJSON = withObject "SnapshotType" $ \o -> do
158 t <- o .: "type"
159 case asText t of
160 "nightly" -> return STNightly
161 "lts" -> STLTS
162 <$> o .: "major"
163 <*> o .: "minor"
164 _ -> fail $ "Unknown type for SnapshotType: " ++ unpack t
166data CreateBundleV2 = CreateBundleV2
167 { cb2Plan :: BuildPlan
168 , cb2Type :: SnapshotType
169 , cb2DocsDir :: FilePath
170 , cb2Dest :: FilePath
171 }
173-- | Create a V2 bundle, which contains the build plan, metadata, docs, and doc
174-- map.
175createBundleV2 :: CreateBundleV2 -> IO ()
176createBundleV2 CreateBundleV2 {..} = do
177 docsDir <- canonicalizePath cb2DocsDir
178 docMap <- docsListing cb2Plan cb2DocsDir
180 Y.encodeFile (fpToString $ docsDir </> "build-plan.yaml") cb2Plan
181 Y.encodeFile (fpToString $ docsDir </> "build-type.yaml") cb2Type
182 Y.encodeFile (fpToString $ docsDir </> "docs-map.yaml") docMap
183 void $ writeIndexStyle Nothing cb2DocsDir
185 currentDir <- getWorkingDirectory
186 files <- listDirectory docsDir
188 let args = "cfJ"
189 : fpToString (currentDir </> cb2Dest)
190 : "--dereference"
191 : map (fpToString . filename) files
192 cp = (proc "tar" args) { cwd = Just $ fpToString docsDir }
193 withCheckedProcess cp $ \ClosedStream Inherited Inherited -> return ()
195writeIndexStyle :: Maybe Text -- ^ snapshot id
196 -> FilePath -- ^ docs dir
197 -> IO [String]
198writeIndexStyle msnapid dir = do
199 dirs <- fmap sort
200 $ runResourceT
201 $ sourceDirectory dir
202 $$ filterMC (liftIO . isDirectory)
203 =$ mapC (fpToString . filename)
204 =$ sinkList
205 writeFile (dir </> "index.html") $ mkIndex
206 (unpack <$> msnapid)
207 dirs
208 writeFile (dir </> "style.css") styleCss
209 return dirs
211mkIndex :: Maybe String -> [String] -> String
212mkIndex msnapid dirs = concat
213 [ "<!DOCTYPE html>\n<html lang='en'><head><title>Haddocks index</title>"
214 , "<link rel='stylesheet' href='https://maxcdn.bootstrapcdn.com/bootstrap/3.2.0/css/bootstrap.min.css'>"
215 , "<link rel='stylesheet' href='style.css'>"
216 , "<link rel='shortcut icon' href='http://www.stackage.org/static/img/favicon.ico' />"
217 , "</head>"
218 , "<body><div class='container'>"
219 , "<div class='row'><div class='span12 col-md-12'>"
220 , "<h1>Haddock documentation index</h1>"
221 , flip foldMap msnapid $ \snapid -> concat
222 [ "<p class='return'><a href=\"http://www.stackage.org/stackage/"
223 , snapid
224 , "\">Return to snapshot</a></p>"
225 ]
226 , "<ul>"
227 , concatMap toLI dirs
228 , "</ul></div></div></div></body></html>"
229 ]
230 where
231 toLI name = concat
232 [ "<li><a href='"
233 , name
234 , "/index.html'>"
235 , name
236 , "</a></li>"
237 ]
239styleCss :: String
240styleCss = concat
241 [ "@media (min-width: 530px) {"
242 , "ul { -webkit-column-count: 2; -moz-column-count: 2; column-count: 2 }"
243 , "}"
244 , "@media (min-width: 760px) {"
245 , "ul { -webkit-column-count: 3; -moz-column-count: 3; column-count: 3 }"
246 , "}"
247 , "ul {"
248 , " margin-left: 0;"
249 , " padding-left: 0;"
250 , " list-style-type: none;"
251 , "}"
252 , "body {"
253 , " background: #f0f0f0;"
254 , " font-family: 'Lato', sans-serif;"
255 , " text-shadow: 1px 1px 1px #ffffff;"
256 , " font-size: 20px;"
257 , " line-height: 30px;"
258 , " padding-bottom: 5em;"
259 , "}"
260 , "h1 {"
261 , " font-weight: normal;"
262 , " color: #06537d;"
263 , " font-size: 45px;"
264 , "}"
265 , ".return a {"
266 , " color: #06537d;"
267 , " font-style: italic;"
268 , "}"
269 , ".return {"
270 , " margin-bottom: 1em;"
271 , "}"]