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
|
{- git-annex assistant webapp thread
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes, CPP #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Assistant.Threads.WebApp where
import Assistant.Common
import Assistant.WebApp
import Assistant.WebApp.Types
import Assistant.WebApp.DashBoard
import Assistant.WebApp.SideBar
import Assistant.WebApp.Notifications
import Assistant.WebApp.Configurators
import Assistant.WebApp.Configurators.Edit
import Assistant.WebApp.Configurators.Local
import Assistant.WebApp.Configurators.Ssh
import Assistant.WebApp.Configurators.Pairing
#ifdef WITH_S3
import Assistant.WebApp.Configurators.S3
#endif
import Assistant.WebApp.Configurators.XMPP
import Assistant.WebApp.Documentation
import Assistant.WebApp.OtherRepos
import Assistant.ThreadedMonad
import Utility.WebApp
import Utility.FileMode
import Utility.TempFile
import Git
import Yesod
import Yesod.Static
import Network.Socket (PortNumber)
import Data.Text (pack, unpack)
thisThread :: String
thisThread = "WebApp"
mkYesodDispatch "WebApp" $(parseRoutesFile "Assistant/WebApp/routes")
type Url = String
webAppThread
:: AssistantData
-> UrlRenderer
-> Bool
-> Maybe (IO String)
-> Maybe (Url -> FilePath -> IO ())
-> NamedThread
webAppThread assistantdata urlrenderer noannex postfirstrun onstartup = thread $ liftIO $ do
webapp <- WebApp
<$> pure assistantdata
<*> (pack <$> genRandomToken)
<*> getreldir
<*> pure $(embed "static")
<*> newWebAppState
<*> pure postfirstrun
<*> pure noannex
setUrlRenderer urlrenderer $ yesodRender webapp (pack "")
app <- toWaiAppPlain webapp
app' <- ifM debugEnabled
( return $ httpDebugLogger app
, return app
)
runWebApp app' $ \port -> if noannex
then withTempFile "webapp.html" $ \tmpfile _ ->
go port webapp tmpfile Nothing
else do
let st = threadState assistantdata
htmlshim <- runThreadState st $ fromRepo gitAnnexHtmlShim
urlfile <- runThreadState st $ fromRepo gitAnnexUrlFile
go port webapp htmlshim (Just urlfile)
where
thread = NamedThread thisThread
getreldir
| noannex = return Nothing
| otherwise = Just <$>
(relHome =<< absPath
=<< runThreadState (threadState assistantdata) (fromRepo repoPath))
go port webapp htmlshim urlfile = do
brokendebug thisThread ["running on port", show port]
let url = myUrl webapp port
maybe noop (`writeFile` url) urlfile
writeHtmlShim url htmlshim
maybe noop (\a -> a url htmlshim) onstartup
{- Creates a html shim file that's used to redirect into the webapp,
- to avoid exposing the secretToken when launching the web browser. -}
writeHtmlShim :: String -> FilePath -> IO ()
writeHtmlShim url file = viaTmp go file $ genHtmlShim url
where
go tmpfile content = do
h <- openFile tmpfile WriteMode
modifyFileMode tmpfile $ removeModes [groupReadMode, otherReadMode]
hPutStr h content
hClose h
{- TODO: generate this static file using Yesod. -}
genHtmlShim :: String -> String
genHtmlShim url = unlines
[ "<html>"
, "<head>"
, "<title>Starting webapp...</title>"
, "<meta http-equiv=\"refresh\" content=\"0; URL="++url++"\">"
, "<body>"
, "<p>"
, "<a href=\"" ++ url ++ "\">Starting webapp...</a>"
, "</p>"
, "</body>"
, "</html>"
]
myUrl :: WebApp -> PortNumber -> Url
myUrl webapp port = unpack $ yesodRender webapp urlbase HomeR []
where
urlbase = pack $ "http://localhost:" ++ show port
|
