From a3bc8e93e3c7a37347ba3d2fa925697b2364d12a Mon Sep 17 00:00:00 2001 From: Camil Staps Date: Thu, 29 Oct 2020 10:22:48 +0100 Subject: [PATCH] Add an interface to the GitLab API to check if a new version is available --- src/GitLab/API.dcl | 16 ++++++++ src/GitLab/API.icl | 32 ++++++++++++++++ src/GitLab/API/Tags.dcl | 51 +++++++++++++++++++++++++ src/GitLab/API/Tags.icl | 82 +++++++++++++++++++++++++++++++++++++++++ src/Gui/Main.icl | 27 ++++++++++++-- src/Gui/Version.dcl | 7 ++++ src/Gui/Version.icl | 63 +++++++++++++++++++++++++++++++ 7 files changed, 274 insertions(+), 4 deletions(-) create mode 100644 src/GitLab/API.dcl create mode 100644 src/GitLab/API.icl create mode 100644 src/GitLab/API/Tags.dcl create mode 100644 src/GitLab/API/Tags.icl create mode 100644 src/Gui/Version.dcl create mode 100644 src/Gui/Version.icl diff --git a/src/GitLab/API.dcl b/src/GitLab/API.dcl new file mode 100644 index 0000000..9ed993b --- /dev/null +++ b/src/GitLab/API.dcl @@ -0,0 +1,16 @@ +definition module GitLab.API + +from Data.GenEq import generic gEq +from Text.GenJSON import :: JSONNode, generic JSONEncode, generic JSONDecode +from Text.URI import :: URI + +from iTasks.Internal.Generic.Visualization import :: TextFormat, generic gText +from iTasks.UI.Editor import :: Editor +from iTasks.UI.Editor.Generic import :: EditorPurpose, generic gEditor +from iTasks.WF.Definition import :: Task, class iTask + +:: Endpoint goal (:== URI) + +toEndpoint :: !String -> Endpoint goal + +fetch :: !(Endpoint goal) -> Task goal | iTask goal diff --git a/src/GitLab/API.icl b/src/GitLab/API.icl new file mode 100644 index 0000000..da6916f --- /dev/null +++ b/src/GitLab/API.icl @@ -0,0 +1,32 @@ +implementation module GitLab.API + +import StdEnv + +import Text.URI + +import iTasks.Extensions.Web + +:: Endpoint goal :== URI + +toEndpoint :: !String -> Endpoint goal +toEndpoint path = + { nullURI + & uriScheme = ?Just "http" + , uriRegName = ?Just "gitlab.com" + , uriPath = "/api/v4/"+++path + } + +fetch :: !(Endpoint goal) -> Task goal | iTask goal +fetch endpoint = callHTTP + HTTP_GET + endpoint + "" + (\{rsp_code,rsp_data,rsp_headers} + | rsp_code <> 200 -> + Error ("API failed with response code "+++toString rsp_code+++toSingleLineText rsp_headers) + | otherwise -> + case fromJSON (fromString rsp_data) of + ?Just goal -> + Ok goal + ?None -> + Error "Failed to parse API response") diff --git a/src/GitLab/API/Tags.dcl b/src/GitLab/API/Tags.dcl new file mode 100644 index 0000000..8be0ce6 --- /dev/null +++ b/src/GitLab/API/Tags.dcl @@ -0,0 +1,51 @@ +definition module GitLab.API.Tags + +from System.Time import :: Tm +from Text.GenJSON import :: JSONNode, generic JSONDecode, generic JSONEncode + +from GitLab.API import :: Endpoint + +:: Tag = + { name :: !String + , message :: !?String + //, target :: !String + , commit :: !Commit + //, release :: !?Release + , protected :: !Bool + } + +:: Commit = + { id :: !String + , short_id :: !String + , created_at :: !GitDate + , parent_ids :: ![String] + , title :: !String + , message :: !String + , author_name :: !String + , author_email :: !String + , authored_date :: !GitDate + , committer_name :: !String + , committer_email :: !String + , committed_date :: !GitDate + , web_url :: !String + } + +:: GitDate = + { timestamp :: !Tm + , timezone :: !Timezone + } + +:: Timezone = + { positive :: !Bool + , offset_h :: !Int + , offset_m :: !Int + } + +derive JSONDecode Tag, Commit, GitDate +derive JSONEncode Tag, Commit, GitDate + +/** + * The API endpoint for a repository's tags. + * @param The repository ID. + */ +repository_tags :: !Int -> Endpoint [Tag] diff --git a/src/GitLab/API/Tags.icl b/src/GitLab/API/Tags.icl new file mode 100644 index 0000000..454f682 --- /dev/null +++ b/src/GitLab/API/Tags.icl @@ -0,0 +1,82 @@ +implementation module GitLab.API.Tags + +import StdEnv + +import Control.Applicative +import Data.Func +import Data.List +import System.Time +from Text import concat3, concat5 +import Text.GenJSON + +import GitLab.API + +derive JSONDecode Tag, Commit +derive JSONEncode Tag, Commit + +JSONEncode{|GitDate|} _ {timestamp,timezone} = pure $ JSONString $ concat5 + (strfTime "%Y-%m-%dT%H:%M:%S.000" timestamp) + (if timezone.positive "+" "-") + (let s = toString timezone.offset_h in if (size s < 2) ("0"+++s) s) + ":" + (let s = toString timezone.offset_m in if (size s < 2) ("0"+++s) s) + +JSONDecode{|GitDate|} _ json=:[JSONString date:rest] = case parse date of + ?Just date -> (?Just date, rest) + _ -> (?None, json) +where + parse s + | size s <> 29 + = ?None + | s.[4] <> '-' || s.[7] <> '-' || s.[10] <> 'T' + = ?None + | s.[13] <> ':' || s.[16] <> ':' || s.[19] <> '.' + = ?None + | (s.[23] <> '+' && s.[23] <> '-') || s.[26] <> ':' + = ?None + | year == 0 || month == 0 || day == 0 + = ?None + | hour == 0 && hour_s <> "00" || hour < 0 || hour > 23 + = ?None + | minute == 0 && minute_s <> "00" || minute < 0 || minute > 59 + = ?None + | second == 0 && second_s <> "00" || second < 0 || second > 61 + = ?None + | msecs == 0 && msecs_s <> "000" || msecs < 0 + = ?None + | offset_h == 0 && offset_h_s <> "00" || offset_h < 0 + = ?None + | offset_m == 0 && offset_m_s <> "00" || offset_m < 0 + = ?None + = ?Just {timestamp=tm, timezone=timezone} + where + year = toInt (s % (0,3)) + month = toInt (s % (5,6)) + day = toInt (s % (8,9)) + hour = toInt hour_s; hour_s = s % (11,12) + minute = toInt minute_s; minute_s = s % (14,15) + second = toInt second_s; second_s = s % (17,18) + msecs = toInt msecs_s; msecs_s = s % (20,22) + offset_h = toInt offset_h_s; offset_h_s = s % (24,25) + offset_m = toInt offset_m_s; offset_m_s = s % (27,28) + + tm = + { sec = second + , min = minute + , hour = hour + , mday = day + , mon = month + , year = year + , wday = -1 + , yday = -1 + , isdst = -1 + } + timezone = + { positive = s.[23] == '+' + , offset_h = offset_h + , offset_m = offset_m + } +JSONDecode{|GitDate|} _ json = (?None, json) + +repository_tags :: !Int -> Endpoint [Tag] +repository_tags repo_id = toEndpoint (concat3 "projects/" (toString repo_id) "/repository/tags") diff --git a/src/Gui/Main.icl b/src/Gui/Main.icl index 25e01c9..c221ab4 100644 --- a/src/Gui/Main.icl +++ b/src/Gui/Main.icl @@ -9,7 +9,7 @@ import qualified Data.Map import Data.Map.GenJSON import System.OS import qualified Text -from Text import class Text, instance Text String, concat5 +from Text import class Text, instance Text String, concat3, concat5 import Text.HTML import ABC.Interpreter @@ -29,6 +29,9 @@ import Electron.Util import TextFabric +import GitLab.API +import GitLab.API.Tags + import MBQS.Languages.Parsers import MBQS.Model import MBQS.Model.Serialization @@ -38,6 +41,7 @@ import Gui.NewSheet import Gui.Settings import Gui.Shares import Gui.Util +import Gui.Version import Gui.Window derive class iTask ApplicationMenu @@ -302,18 +306,25 @@ aboutDialog :: !ElectronWindow -> Task () aboutDialog parent = createWindow { defaultOptions - & task = view + & task = \_ -> view , parent = ?Just parent , width = 600 , height = 400 } @! () where - view _ = + view = getVersion >>- \version -> viewInformation [] (about version) >>* - [ OnAction ActionClose $ always closeWindow + [ OnAction (Action "Check for updates") $ always $ + checkForUpdates >>- \mbTag -> + viewInformation [] (updateInfo mbTag) >>* + [ OnAction (Action "Back") $ always view + , OnAction ActionClose $ always closeWindow + ] + , OnAction ActionClose $ always closeWindow ] + about version = DivTag [] [ H1Tag [] [ EmTag [] [Text "Məḇaqqēš"] @@ -342,3 +353,11 @@ where , Text " for the source code and to contribute. " ] ] + + updateInfo ?None = PTag [] [Text "There is no update available."] + updateInfo (?Just {Tag|name}) = PTag [] + [ Text (concat3 "You can update to version " name ". Go to ") + , let url = "gitlab.com/camilstaps/mbqs/tags/"+++name in + ATag [HrefAttr ("https://"+++url)] [Text url] + , Text " to download it." + ] diff --git a/src/Gui/Version.dcl b/src/Gui/Version.dcl new file mode 100644 index 0000000..c6de72f --- /dev/null +++ b/src/Gui/Version.dcl @@ -0,0 +1,7 @@ +definition module Gui.Version + +from iTasks.WF.Definition import :: Task + +from GitLab.API.Tags import :: Tag + +checkForUpdates :: Task (?Tag) diff --git a/src/Gui/Version.icl b/src/Gui/Version.icl new file mode 100644 index 0000000..6ce8fac --- /dev/null +++ b/src/Gui/Version.icl @@ -0,0 +1,63 @@ +implementation module Gui.Version + +import StdEnv + +import Data.Func +import Data.Functor +import Data.Tuple + +import iTasks + +import Electron.Util + +import GitLab.API +import GitLab.API.Tags + +derive class iTask \ JSONEncode, JSONDecode Tag, Commit, GitDate, Tm, Timezone + +REPOSITORY_ID :== 14989816 + +checkForUpdates :: Task (?Tag) +checkForUpdates = + getVersion @ + (\v -> (fromJust (parse_version False v), ?None)) >>- \cur -> + fetch (repository_tags REPOSITORY_ID) @ + map (\t -> flip tuple (?Just t) <$> parse_version True t.Tag.name) @ + catMaybes @ (++) [cur] @ maxListBy ((<) `on` fst) >>- \latest -> + return (snd latest) + +parse_version :: !Bool !String -> ?(Int,Int,Int) +parse_version starts_with_v s = parse 0 3 (-1,-1,-1) s +where + parse :: !Int !Int !(!Int,!Int,!Int) !String -> ?(Int,Int,Int) + parse i major_minor_rev v s + | i >= size s + | major_minor_rev == 1 + = ?Just v + = ?None + parse 0 major_minor_rev v=:(maj,min,rev) s + | starts_with_v + | s.[0] == 'v' && size s >= 2 && isDigit s.[1] + = parse 1 major_minor_rev v s + = ?None + | isDigit s.[0] + = parse 1 major_minor_rev (digitToInt s.[0],min,rev) s + = ?None + parse i major_minor_rev (maj,min,rev) s + | isDigit s.[i] + | major_minor_rev == 3 + = parse (i+1) major_minor_rev (maj*10+digitToInt s.[i],min,rev) s + | major_minor_rev == 2 + = parse (i+1) major_minor_rev (maj,min*10+digitToInt s.[i],rev) s + | major_minor_rev == 1 + = parse (i+1) major_minor_rev (maj,min,rev*10+digitToInt s.[i]) s + = abort "internal error in parse_version\n" + | s.[i] == '.' && size s > i+1 && isDigit s.[i+1] + | major_minor_rev == 3 + = parse (i+2) 2 (maj,digitToInt s.[i],rev) s + | major_minor_rev == 2 + = parse (i+2) 2 (maj,min,digitToInt s.[i]) s + | major_minor_rev == 1 + = ?None + = abort "internal error in parse_version\n" + = ?None -- GitLab