git.iko.soy/obelisk
on 3caa3db help sign in
obelisk/lib/command/src/Obelisk/Command/Run.hs
102 lines 3.8 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE FlexibleContexts #-}
3module Obelisk.Command.Run where
5import qualified Control.Exception as E
6import Control.Monad
7import Data.Either
8import Data.List
9import Control.Monad.Reader (ask)
10import Data.Maybe
11import Control.Monad.IO.Class (liftIO)
12import Data.Monoid
13import qualified Data.Text as T
14import Data.List.NonEmpty as NE
15import Distribution.Utils.Generic (withUTF8FileContents)
16import Distribution.PackageDescription.Parse (parseGenericPackageDescription, ParseResult(..))
17import Distribution.Types.BuildInfo
18import Distribution.Types.CondTree
19import Distribution.Types.Library
20import Distribution.Types.GenericPackageDescription
21import Network.Socket
22import System.Directory
23import System.FilePath
24import System.IO.Temp (withSystemTempDirectory)
25import System.Process (callCommand)
27import Obelisk.App (MonadObelisk, ObeliskT, runObelisk)
28import Obelisk.CLI (putLog, failWith, Severity(..))
30-- NOTE: `run` is not polymorphic like the rest because we use StaticPtr to invoke it.
31run :: ObeliskT IO ()
32run = do
33 freePort <- liftIO getFreePort
34 pkgs <- liftIO getLocalPkgs
35 (pkgDirErrs, hsSrcDirs) <- fmap partitionEithers $ forM pkgs $ \pkg -> do
36 let cabalFp = pkg </> pkg <.> "cabal"
37 xs <- parseHsSrcDir cabalFp
38 return $ case xs of
39 Nothing -> Left pkg
40 Just hsSrcDirs -> Right $ toList $ fmap (pkg </>) hsSrcDirs
41 when (null hsSrcDirs) $
42 failWith $ T.pack $ "No valid pkgs found in " <> intercalate ", " pkgs
43 when (not (null pkgDirErrs)) $
44 putLog Warning $ T.pack $ "Failed to find pkgs in " <> intercalate ", " pkgDirErrs
45 let dotGhci = unlines
46 [ ":set -i" <> intercalate ":" (mconcat hsSrcDirs)
47 , ":add Backend Frontend"
48 , ":module + Obelisk.Run Frontend Backend"
49 ]
50 testCmd = unwords ["Obelisk.Run.run", show freePort , "backend", "frontend"]
51 withSystemTempDirectory "ob-ghci" $ \fp -> do
52 let dotGhciPath = fp </> ".ghci"
53 liftIO $ do
54 writeFile dotGhciPath dotGhci
55 runDev dotGhciPath $ Just testCmd
57-- | Relative paths to local packages of an obelisk project
58-- TODO a way to query this
59getLocalPkgs :: IO [FilePath]
60getLocalPkgs = return ["backend", "common", "frontend"]
62parseHsSrcDir
63 :: MonadObelisk m
64 => FilePath -- ^ package cabal file path
65 -> m (Maybe (NE.NonEmpty FilePath)) -- ^ List of hs src dirs of the library component
66parseHsSrcDir cabalFp = do
67 exists <- liftIO $ doesFileExist cabalFp
68 if exists
69 then do
70 c <- ask
71 liftIO $ withUTF8FileContents cabalFp $ \cabal -> runObelisk c $ do
72 case parseGenericPackageDescription cabal of
73 ParseOk warnings gpkg -> do
74 mapM_ (putLog Warning) $ fmap (T.pack . show) warnings
75 return $ do
76 (_, lib) <- simplifyCondTree (const $ pure True) <$> condLibrary gpkg
77 pure $ fromMaybe (pure ".") $ NE.nonEmpty $ hsSourceDirs $ libBuildInfo lib
78 ParseFailed e -> do
79 putLog Error $ T.pack $ "Failed to parse cabal file: " <> show e
80 return Nothing
81 else return Nothing
83-- | Dev
84runDev :: FilePath -> Maybe String -> IO ()
85runDev dotGhci mcmd = callCommand $ unwords $ "ghcid" : ghcidOpts
86 where
87 ghcidOpts =
88 [ "-W"
89 , "--command='ghci -ghci-script " <> dotGhci <> "' "
90 , "--reload=config"
91 , "--outputfile=ghcid-output.txt"
92 ] <> maybeToList (flip fmap mcmd $ \cmd -> "--test='" <> cmd <> "'")
94getFreePort :: IO PortNumber
95getFreePort = withSocketsDo $ do
96 addr:_ <- getAddrInfo (Just defaultHints) (Just "127.0.0.1") (Just "0")
97 E.bracket (open addr) close socketPort
98 where
99 open addr = do
100 sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
101 bind sock (addrAddress addr)
102 return sock