git.iko.soy/obelisk
on 63c7b21 help sign in
obelisk/lib/command/src/Obelisk/Command/Run.hs
205 lines 7.5 kB history raw
1{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE LambdaCase #-}
3{-# LANGUAGE MultiParamTypeClasses #-}
4{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE ScopedTypeVariables #-}
6module Obelisk.Command.Run where
8import Control.Exception (bracket)
9import Control.Monad
10import Control.Monad.IO.Class (liftIO)
11import Control.Monad.Reader (MonadIO)
12import Data.Either
13import Data.List
14import Data.List.NonEmpty as NE
15import Data.Maybe
16import qualified Data.Text as T
17import Distribution.PackageDescription.Parsec (parseGenericPackageDescription)
18import Distribution.Parsec.ParseResult (runParseResult)
19import Distribution.Pretty
20import Distribution.Types.BuildInfo
21import Distribution.Types.CondTree
22import Distribution.Types.GenericPackageDescription
23import Distribution.Types.Library
24import Distribution.Utils.Generic
25import Hpack.Config
26import Hpack.Render
27import Hpack.Yaml
28import Language.Haskell.Extension
29import Network.Socket hiding (Debug)
30import System.Directory
31import System.FilePath
32import System.Process (proc)
33import System.IO.Temp (withSystemTempDirectory)
34import Data.ByteString (ByteString)
36import Obelisk.App (MonadObelisk, ObeliskT)
37import Obelisk.CliApp
38 ( CliT (..), HasCliConfig, Severity (..)
39 , callCommand, failWith, getCliConfig, putLog
40 , readProcessAndLogStderr, runCli)
41import Obelisk.Command.Project (inProjectShell, withProjectRoot)
43data CabalPackageInfo = CabalPackageInfo
44 { _cabalPackageInfo_packageRoot :: FilePath
45 , _cabalPackageInfo_sourceDirs :: NE.NonEmpty FilePath
46 -- ^ List of hs src dirs of the library component
47 , _cabalPackageInfo_defaultExtensions :: [Extension]
48 -- ^ List of globally enable extensions of the library component
49 }
51-- NOTE: `run` is not polymorphic like the rest because we use StaticPtr to invoke it.
52run :: ObeliskT IO ()
53run = do
54 pkgs <- getLocalPkgs
55 withGhciScript pkgs $ \dotGhciPath -> do
56 freePort <- getFreePort
57 assets <- withProjectRoot "." $ \root ->
58 -- `--raw` is not available with old nix-instantiate. It drops quotation
59 -- marks and trailing newline, so is very convenient for shelling out.
60 readProcessAndLogStderr Debug $
61 proc "nix" ["eval", "-f", root, "passthru.staticFilesImpure", "--raw"]
62 putLog Debug $ "Assets impurely loaded from: " <> assets
63 runGhcid dotGhciPath $ Just $ unwords
64 [ "run"
65 , show freePort
66 , "(runServeAsset " ++ show assets ++ ")"
67 , "Backend.backend"
68 , "Frontend.frontend"
69 ]
71runRepl :: MonadObelisk m => m ()
72runRepl = do
73 pkgs <- getLocalPkgs
74 withGhciScript pkgs $ \dotGhciPath -> do
75 runGhciRepl dotGhciPath
77runWatch :: MonadObelisk m => m ()
78runWatch = do
79 pkgs <- getLocalPkgs
80 withGhciScript pkgs $ \dotGhciPath -> runGhcid dotGhciPath Nothing
82-- | Relative paths to local packages of an obelisk project
83-- TODO a way to query this
84getLocalPkgs :: Applicative f => f [FilePath]
85getLocalPkgs = pure ["backend", "common", "frontend"]
87parseCabalPackage
88 :: (MonadObelisk m)
89 => FilePath -- ^ package directory
90 -> m (Maybe CabalPackageInfo)
91parseCabalPackage dir = do
92 let cabalFp = dir </> (takeBaseName dir <> ".cabal")
93 hpackFp = dir </> "package.yaml"
94 hasCabal <- liftIO $ doesFileExist cabalFp
95 hasHpack <- liftIO $ doesFileExist hpackFp
97 mCabalContents <- if hasCabal
98 then Just <$> liftIO (readUTF8File cabalFp)
99 else if hasHpack
100 then do
101 let decodeOptions = DecodeOptions hpackFp Nothing decodeYaml
102 liftIO (readPackageConfig decodeOptions) >>= \case
103 Left err -> do
104 putLog Error $ T.pack $ "Failed to parse " <> hpackFp <> ": " <> err
105 return Nothing
106 Right (DecodeResult hpackPackage _ _) -> do
107 return $ Just $ renderPackage [] hpackPackage
108 else return Nothing
110 fmap join $ forM mCabalContents $ \cabalContents -> do
111 let (warnings, result) = runParseResult $ parseGenericPackageDescription $
112 toUTF8BS $ cabalContents
113 mapM_ (putLog Warning) $ fmap (T.pack . show) warnings
114 case result of
115 Right gpkg -> do
116 return $ do
117 (_, lib) <- simplifyCondTree (const $ pure True) <$> condLibrary gpkg
118 pure $ CabalPackageInfo
119 { _cabalPackageInfo_packageRoot = takeDirectory cabalFp
120 , _cabalPackageInfo_sourceDirs =
121 fromMaybe (pure ".") $ NE.nonEmpty $ hsSourceDirs $ libBuildInfo lib
122 , _cabalPackageInfo_defaultExtensions =
123 defaultExtensions $ libBuildInfo lib
124 }
125 Left (_, errors) -> do
126 putLog Error $ T.pack $ "Failed to parse " <> cabalFp <> ":"
127 mapM_ (putLog Error) $ fmap (T.pack . show) errors
128 return Nothing
130withUTF8FileContentsM :: (MonadIO m, HasCliConfig e m) => FilePath -> (ByteString -> CliT e IO a) -> m a
131withUTF8FileContentsM fp f = do
132 c <- getCliConfig
133 liftIO $ withUTF8FileContents fp $ runCli c . f . toUTF8BS
135-- | Create ghci configuration to load the given packages
136withGhciScript
137 :: MonadObelisk m
138 => [FilePath] -- ^ List of packages to load into ghci
139 -> (FilePath -> m ()) -- ^ Action to run with the path to generated temporory .ghci
140 -> m ()
141withGhciScript pkgs f = do
142 (pkgDirErrs, packageInfos) <- fmap partitionEithers $ forM pkgs $ \pkg -> do
143 flip fmap (parseCabalPackage pkg) $ \case
144 Nothing -> Left pkg
145 Just packageInfo -> Right packageInfo
147 when (null packageInfos) $
148 failWith $ T.pack $ "No valid pkgs found in " <> intercalate ", " pkgs
149 unless (null pkgDirErrs) $
150 putLog Warning $ T.pack $ "Failed to find pkgs in " <> intercalate ", " pkgDirErrs
152 let extensions = packageInfos >>= _cabalPackageInfo_defaultExtensions
153 extensionsLine = if extensions == mempty
154 then ""
155 else ":set " <> intercalate " " ((("-X" <>) . prettyShow) <$> extensions)
156 dotGhci = unlines $
157 [ ":set -i" <> intercalate ":" (packageInfos >>= rootedSourceDirs)
158 , extensionsLine
159 , ":load Backend Frontend"
160 , "import Obelisk.Run"
161 , "import qualified Frontend"
162 , "import qualified Backend"
163 ]
164 withSystemTempDirectory "ob-ghci" $ \fp -> do
165 let dotGhciPath = fp </> ".ghci"
166 liftIO $ writeFile dotGhciPath dotGhci
167 f dotGhciPath
169 where
170 rootedSourceDirs pkg = NE.toList $
171 (_cabalPackageInfo_packageRoot pkg </>) <$> _cabalPackageInfo_sourceDirs pkg
173-- | Run ghci repl
174runGhciRepl
175 :: MonadObelisk m
176 => FilePath -- ^ Path to .ghci
177 -> m ()
178runGhciRepl dotGhci = inProjectShell "ghc" $ unwords $ "ghci" : ["-ghci-script", dotGhci]
180-- | Run ghcid
181runGhcid
182 :: MonadObelisk m
183 => FilePath -- ^ Path to .ghci
184 -> Maybe String -- ^ Optional command to run at every reload
185 -> m ()
186runGhcid dotGhci mcmd = callCommand $ unwords $ "ghcid" : opts
187 where
188 opts =
189 [ "-W"
190 --TODO: The decision of whether to use -fwarn-redundant-constraints should probably be made by the user
191 , "--command='ghci -Wall -ignore-dot-ghci -fwarn-redundant-constraints -ghci-script " <> dotGhci <> "' "
192 , "--reload=config"
193 , "--outputfile=ghcid-output.txt"
194 ] <> testCmd
195 testCmd = maybeToList (flip fmap mcmd $ \cmd -> "--test='" <> cmd <> "'")
197getFreePort :: MonadIO m => m PortNumber
198getFreePort = liftIO $ withSocketsDo $ do
199 addr:_ <- getAddrInfo (Just defaultHints) (Just "127.0.0.1") (Just "0")
200 bracket (open addr) close socketPort
201 where
202 open addr = do
203 sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
204 bind sock (addrAddress addr)
205 return sock