@@ -0,0 +1,92 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Obelisk.Command.Run where
3+
4+import qualified Control.Exception as E
5+import Control.Monad
6+import Data.Either
7+import Data.List
8+import Data.Maybe
9+import Data.Monoid
10+import Data.List.NonEmpty as NE
11+import Distribution.Utils.Generic (withUTF8FileContents)
12+import Distribution.PackageDescription.Parse (parseGenericPackageDescription, ParseResult(..))
13+import Distribution.Types.BuildInfo
14+import Distribution.Types.CondTree
15+import Distribution.Types.Library
16+import Distribution.Types.GenericPackageDescription
17+import Network.Socket
18+import System.Directory
19+import System.FilePath
20+import System.IO.Temp (withSystemTempDirectory)
21+import System.Process (callCommand)
22+
23+run :: IO ()
24+run = do
25+ freePort <- getFreePort
26+ pkgs <- getLocalPkgs
27+ (pkgDirErrs, hsSrcDirs) <- fmap partitionEithers $ forM pkgs $ \pkg -> do
28+ let cabalFp = pkg </> pkg <.> "cabal"
29+ xs <- parseHsSrcDir cabalFp
30+ return $ case xs of
31+ Nothing -> Left pkg
32+ Just hsSrcDirs -> Right $ toList $ fmap (pkg </>) hsSrcDirs
33+ when (null hsSrcDirs) $
34+ fail $ "No valid pkgs found in " <> intercalate ", " pkgs
35+ when (not (null pkgDirErrs)) $
36+ putStrLn $ "Failed to find pkgs in " <> intercalate ", " pkgDirErrs
37+ let dotGhci = unlines
38+ [ ":set args --quiet --port " <> show freePort
39+ , ":set -i" <> intercalate ":" (mconcat hsSrcDirs)
40+ , ":add Backend Frontend"
41+ , ":module + Control.Concurrent Obelisk.Widget.Run Frontend Backend"
42+ ]
43+ testCmd = unlines
44+ [ "backendId <- forkIO backend"
45+ , "let conf = defRunConfig { _runConfig_redirectPort = " <> show freePort <> "}"
46+ , "runWidget conf frontend"
47+ , "killThread backendId"
48+ ]
49+ withSystemTempDirectory "ob-ghci" $ \fp -> do
50+ let dotGhciPath = fp </> ".ghci"
51+ writeFile dotGhciPath dotGhci
52+ runDev dotGhciPath $ Just testCmd
53+
54+-- | Relative paths to local packages of an obelisk project
55+-- TODO a way to query this
56+getLocalPkgs :: IO [FilePath]
57+getLocalPkgs = return ["backend", "common", "frontend"]
58+
59+parseHsSrcDir :: FilePath -- ^ package cabal file path
60+ -> IO (Maybe (NE.NonEmpty FilePath)) -- ^ List of hs src dirs of the library component
61+parseHsSrcDir cabalFp = do
62+ exists <- doesFileExist cabalFp
63+ if exists
64+ then do
65+ withUTF8FileContents cabalFp $ \cabal -> do
66+ case parseGenericPackageDescription cabal of
67+ ParseOk warnings gpkg -> do
68+ mapM_ print warnings
69+ return $ do
70+ (_, lib) <- simplifyCondTree (const $ pure True) <$> condLibrary gpkg
71+ pure $ fromMaybe (pure ".") $ NE.nonEmpty $ hsSourceDirs $ libBuildInfo lib
72+ ParseFailed _ -> return Nothing
73+ else return Nothing
74+
75+-- | Dev
76+runDev :: FilePath -> Maybe String -> IO ()
77+runDev dotGhci mcmd = callCommand $ unwords $ "ghcid" : ghcidOpts
78+ where
79+ ghcidOpts =
80+ [ "-W"
81+ , "--command='ghci -ghci-script " <> dotGhci <> "' "
82+ ] <> maybeToList (flip fmap mcmd $ \cmd -> " --test=$'" <> cmd <> "'")
83+
84+getFreePort :: IO PortNumber
85+getFreePort = withSocketsDo $ do
86+ addr:_ <- getAddrInfo (Just defaultHints) (Just "127.0.0.1") (Just "0")
87+ E.bracket (open addr) close socketPort
88+ where
89+ open addr = do
90+ sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
91+ bind sock (addrAddress addr)
92+ return sock