@@ -0,0 +1,243 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE LambdaCase #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+module Obelisk.Command.Thunk
5+ ( ThunkPtr (..)
6+ , ThunkRev (..)
7+ , ThunkSource (..)
8+ , GitHubSource (..)
9+ , getLatestRev
10+ , updateThunkToLatest
11+ , createThunkWithLatest
12+ ) where
13+
14+import Control.Exception
15+import Control.Monad
16+import qualified Data.ByteString.Lazy as LBS
17+import Data.Aeson as Aeson
18+import Data.Aeson.Encode.Pretty
19+import Data.Foldable
20+import Data.Git.Ref (Ref)
21+import qualified Data.Git.Ref as Ref
22+import Data.Maybe
23+import Data.Monoid
24+import Data.List.NonEmpty (NonEmpty (..))
25+import qualified Data.List.NonEmpty as NonEmpty
26+import Data.Text (Text)
27+import qualified Data.Text as T
28+import qualified Data.Text.IO as T
29+import Data.Text.Encoding
30+import Data.Yaml (parseMaybe, (.:))
31+import qualified Data.Yaml as Yaml
32+import GitHub
33+import GitHub.Endpoints.Repos.Contents (archiveForR)
34+import GitHub.Data.Name
35+import Network.URI
36+import System.Directory
37+import System.Exit
38+import System.FilePath
39+import System.Process
40+
41+-- | A reference to the exact data that a thunk should translate into
42+data ThunkPtr = ThunkPtr
43+ { _thunkPtr_rev :: ThunkRev
44+ , _thunkPtr_source :: ThunkSource
45+ }
46+ deriving (Show, Eq, Ord)
47+
48+type NixSha256 = Text --TODO: Use a smart constructor and make this actually verify itself
49+
50+-- | A specific revision of data; it may be available from multiple sources
51+data ThunkRev = ThunkRev
52+ { _thunkRev_commit :: Ref
53+ , _thunkRev_nixSha256 :: NixSha256
54+ }
55+ deriving (Show, Eq, Ord)
56+
57+-- | A location from which a thunk's data can be retrieved
58+data ThunkSource
59+ = ThunkSource_GitHub GitHubSource
60+ deriving (Show, Eq, Ord)
61+
62+data GitHubSource = GitHubSource
63+ { _gitHubSource_owner :: Name Owner
64+ , _gitHubSource_repo :: Name Repo
65+ , _gitHubSource_branch :: Maybe (Name Branch)
66+ , _gitHubSource_private :: Bool
67+ }
68+ deriving (Show, Eq, Ord)
69+
70+commitNameToRef :: Name Commit -> Ref
71+commitNameToRef (N c) = Ref.fromHex $ encodeUtf8 c
72+
73+getNixSha256ForUriUnpacked :: URI -> IO NixSha256
74+getNixSha256ForUriUnpacked uri = do
75+ (_, out, _, p) <- runInteractiveProcess "nix-prefetch-url" --TODO: Make this package depend on nix-prefetch-url properly
76+ [ "--unpack"
77+ , "--type"
78+ , "sha256"
79+ , show uri
80+ ] Nothing Nothing
81+ ExitSuccess <- waitForProcess p --TODO: Deal with errors here; usually they're HTTP errors
82+ T.strip <$> T.hGetContents out
83+
84+-- | Get the latest revision available from the given source
85+getLatestRev :: ThunkSource -> IO ThunkRev
86+getLatestRev = \case
87+ ThunkSource_GitHub s -> do
88+ auth <- getHubAuth "github.com"
89+ commitsResult <- executeRequestMaybe auth $ commitsWithOptionsForR
90+ (_gitHubSource_owner s)
91+ (_gitHubSource_repo s)
92+ (FetchAtLeast 1)
93+ $ case _gitHubSource_branch s of
94+ Nothing -> []
95+ Just b -> [CommitQuerySha $ untagName b]
96+ commitInfos <- either throwIO return commitsResult
97+ commitInfo : _ <- return $ toList commitInfos
98+ let commit = commitSha commitInfo
99+ Right archiveUri <- executeRequestMaybe auth $ archiveForR (_gitHubSource_owner s) (_gitHubSource_repo s) ArchiveFormatTarball $ Just $ untagName commit
100+ nixSha256 <- getNixSha256ForUriUnpacked archiveUri
101+ return $ ThunkRev
102+ { _thunkRev_commit = commitNameToRef commit
103+ , _thunkRev_nixSha256 = nixSha256
104+ }
105+
106+-- | Read a thunk and validate that it is only a thunk. If additional data is
107+-- present, fail.
108+readThunk :: FilePath -> IO (Maybe ThunkPtr)
109+readThunk thunkDir = do
110+ let githubJson = thunkDir </> "github.json"
111+ doesFileExist githubJson >>= \case
112+ False -> return Nothing
113+ True -> do
114+ -- Ensure that we recognize the thunk loader
115+ loader <- T.readFile $ thunkDir </> "default.nix"
116+ guard $ loader `elem` gitHubStandaloneLoaders
117+
118+ -- Ensure that there aren't any other files in the thunk
119+ files <- listDirectory thunkDir
120+ guard $ length files == 2
121+
122+ txt <- LBS.readFile githubJson
123+ let p v = do
124+ owner <- v Aeson..: "owner"
125+ repo <- v Aeson..: "repo"
126+ rev <- v Aeson..: "rev"
127+ sha256 <- v Aeson..: "sha256"
128+ branch <- v Aeson..:! "branch"
129+ mPrivate <- v Aeson..:! "private"
130+ return $ ThunkPtr
131+ { _thunkPtr_rev = ThunkRev
132+ { _thunkRev_commit = Ref.fromHexString rev
133+ , _thunkRev_nixSha256 = sha256
134+ }
135+ , _thunkPtr_source = ThunkSource_GitHub $ GitHubSource
136+ { _gitHubSource_owner = owner
137+ , _gitHubSource_repo = repo
138+ , _gitHubSource_branch = branch
139+ , _gitHubSource_private = fromMaybe False mPrivate
140+ }
141+ }
142+ return $ parseMaybe p =<< decode txt
143+
144+overwriteThunk :: FilePath -> ThunkPtr -> IO ()
145+overwriteThunk target thunk = do
146+ -- Ensure that this directory is a valid thunk (i.e. so we aren't losing any data)
147+ Just _ <- readThunk target
148+
149+ --TODO: Is there a safer way to do this overwriting?
150+ removeDirectoryRecursive target
151+ createThunk target thunk
152+
153+createThunk :: FilePath -> ThunkPtr -> IO ()
154+createThunk target thunk = do
155+ createDirectory target
156+ case _thunkPtr_source thunk of
157+ ThunkSource_GitHub s -> do
158+ T.writeFile (target </> "default.nix") $ NonEmpty.head gitHubStandaloneLoaders
159+ LBS.writeFile (target </> "github.json") $
160+ -- It's important that formatting be very consistent here, because
161+ -- otherwise when people update thunks, their patches will be messy
162+ let cfg = defConfig
163+ { confIndent = Spaces 2
164+ , confCompare = keyOrder
165+ [ "owner"
166+ , "repo"
167+ , "branch"
168+ , "private"
169+ , "rev"
170+ , "sha256"
171+ ] <> compare
172+ , confTrailingNewline = True
173+ }
174+ in encodePretty' cfg $ Aeson.object $ catMaybes
175+ [ Just $ "owner" .= _gitHubSource_owner s
176+ , Just $ "repo" .= _gitHubSource_repo s
177+ , case _gitHubSource_branch s of
178+ Just b -> Just $ "branch" .= b
179+ Nothing -> Nothing
180+ , if _gitHubSource_private s
181+ then Just $ "private" .= True
182+ else Nothing
183+ , Just $ "rev" .= Ref.toHexString (_thunkRev_commit (_thunkPtr_rev thunk))
184+ , Just $ "sha256" .= _thunkRev_nixSha256 (_thunkPtr_rev thunk)
185+ ]
186+
187+createThunkWithLatest :: FilePath -> ThunkSource -> IO ()
188+createThunkWithLatest target s = do
189+ rev <- getLatestRev s
190+ createThunk target $ ThunkPtr
191+ { _thunkPtr_source = s
192+ , _thunkPtr_rev = rev
193+ }
194+
195+updateThunkToLatest :: FilePath -> IO ()
196+updateThunkToLatest target = do
197+ Just ptr <- readThunk target
198+ let src = _thunkPtr_source ptr
199+ rev <- getLatestRev src
200+ overwriteThunk target $ ThunkPtr
201+ { _thunkPtr_source = src
202+ , _thunkPtr_rev = rev
203+ }
204+
205+-- | All recognized github standalone loaders, ordered from newest to oldest.
206+-- This tool will only ever produce the newest one when it writes a thunk.
207+gitHubStandaloneLoaders :: NonEmpty Text
208+gitHubStandaloneLoaders =
209+ gitHubStandaloneLoaderV2 :|
210+ [ gitHubStandaloneLoaderV1
211+ ]
212+
213+gitHubStandaloneLoaderV1 :: Text
214+gitHubStandaloneLoaderV1 = T.unlines
215+ [ "import ((import <nixpkgs> {}).fetchFromGitHub (builtins.fromJSON (builtins.readFile ./github.json)))"
216+ ]
217+
218+gitHubStandaloneLoaderV2 :: Text
219+gitHubStandaloneLoaderV2 = T.unlines
220+ [ "# DO NOT HAND-EDIT THIS FILE" --TODO: Add something about how to get more info on Obelisk, etc.
221+ , "import ((import <nixpkgs> {}).fetchFromGitHub ("
222+ , " let json = builtins.fromJSON (builtins.readFile ./github.json);"
223+ , " in { inherit (json) owner repo rev sha256;"
224+ , " private = json.private or false;"
225+ , " }"
226+ , "))"
227+ ]
228+
229+-- | Look for authentication info from the 'hub' command
230+getHubAuth
231+ :: Text -- ^ Domain name
232+ -> IO (Maybe Auth)
233+getHubAuth domain = do
234+ hubConfig <- getXdgDirectory XdgConfig "hub"
235+ Yaml.decodeFile hubConfig >>= \case
236+ Nothing -> return Nothing
237+ Just v -> return $ flip parseMaybe v $ \v' -> do
238+ Yaml.Array domainConfigs <- v' .: domain --TODO: Determine what multiple domainConfigs means
239+ [Yaml.Object domainConfig] <- return $ toList domainConfigs
240+ token <- domainConfig .: "oauth_token"
241+ return $ OAuth $ encodeUtf8 token
242+
243+--TODO: when checking something out, make a shallow clone