diff options
Diffstat (limited to 'users/wpcarro/website/sandbox/learnpianochords/src')
30 files changed, 2931 insertions, 0 deletions
diff --git a/users/wpcarro/website/sandbox/learnpianochords/src/FlashCard.elm b/users/wpcarro/website/sandbox/learnpianochords/src/FlashCard.elm new file mode 100644 index 0000000000..a491752939 --- /dev/null +++ b/users/wpcarro/website/sandbox/learnpianochords/src/FlashCard.elm @@ -0,0 +1,42 @@ +module FlashCard exposing (render) + +import Html exposing (..) +import Html.Attributes exposing (..) +import Html.Events exposing (..) +import Responsive +import State +import Tailwind +import Theory + + +render : + { chord : Theory.Chord + , visible : Bool + } + -> Html State.Msg +render { chord, visible } = + let + classes = + [ "bg-white" + , "fixed" + , "top-0" + , "left-0" + , "z-30" + , "w-screen" + , "h-screen" + , Tailwind.if_ visible "opacity-100" "opacity-0" + ] + in + button + [ classes |> Tailwind.use |> class ] + [ h1 + [ [ "text-center" + , "transform" + , "-rotate-90" + , Responsive.h1 + ] + |> Tailwind.use + |> class + ] + [ text (Theory.viewChord chord) ] + ] diff --git a/users/wpcarro/website/sandbox/learnpianochords/src/Icon.elm b/users/wpcarro/website/sandbox/learnpianochords/src/Icon.elm new file mode 100644 index 0000000000..2c8626b092 --- /dev/null +++ b/users/wpcarro/website/sandbox/learnpianochords/src/Icon.elm @@ -0,0 +1,44 @@ +module Icon exposing (..) + +import Svg exposing (node, svg) +import Svg.Attributes exposing (..) +import UI + + +svgColor color = + let + classes = + case color of + UI.Primary -> + [ "text-gray-500", "fill-current" ] + + UI.Secondary -> + [ "text-gray-300", "fill-current" ] + in + class <| String.join " " classes + + +cog = + svg [ class "icon-cog", viewBox "0 0 24 24", xmlLang "http://www.w3.org/2000/svg" ] + [ Svg.path + [ svgColor UI.Primary + , d "M6.8 3.45c.87-.52 1.82-.92 2.83-1.17a2.5 2.5 0 0 0 4.74 0c1.01.25 1.96.65 2.82 1.17a2.5 2.5 0 0 0 3.36 3.36c.52.86.92 1.8 1.17 2.82a2.5 2.5 0 0 0 0 4.74c-.25 1.01-.65 1.96-1.17 2.82a2.5 2.5 0 0 0-3.36 3.36c-.86.52-1.8.92-2.82 1.17a2.5 2.5 0 0 0-4.74 0c-1.01-.25-1.96-.65-2.82-1.17a2.5 2.5 0 0 0-3.36-3.36 9.94 9.94 0 0 1-1.17-2.82 2.5 2.5 0 0 0 0-4.74c.25-1.01.65-1.96 1.17-2.82a2.5 2.5 0 0 0 3.36-3.36zM12 16a4 4 0 1 0 0-8 4 4 0 0 0 0 8z" + , fill "red" + ] + [] + , node "circle" + [ svgColor UI.Secondary, cx "12", cy "12", r "2" ] + [] + ] + + +close = + svg [ class "icon-close", viewBox "0 0 24 24", xmlLang "http://www.w3.org/2000/svg" ] + [ Svg.path + [ svgColor UI.Primary + , d "M15.78 14.36a1 1 0 0 1-1.42 1.42l-2.82-2.83-2.83 2.83a1 1 0 1 1-1.42-1.42l2.83-2.82L7.3 8.7a1 1 0 0 1 1.42-1.42l2.83 2.83 2.82-2.83a1 1 0 0 1 1.42 1.42l-2.83 2.83 2.83 2.82z" + , fill "red" + , fillRule "evenodd" + ] + [] + ] diff --git a/users/wpcarro/website/sandbox/learnpianochords/src/Main.elm b/users/wpcarro/website/sandbox/learnpianochords/src/Main.elm new file mode 100644 index 0000000000..b066fb2f6f --- /dev/null +++ b/users/wpcarro/website/sandbox/learnpianochords/src/Main.elm @@ -0,0 +1,44 @@ +module Main exposing (main) + +import Browser +import Html exposing (..) +import Misc +import Overview +import Practice +import Preferences +import State +import Time exposing (..) + + +subscriptions : State.Model -> Sub State.Msg +subscriptions model = + if model.isPaused then + Sub.none + + else + Sub.batch + [ Time.every (model.tempo * 2 |> Misc.bpmToMilliseconds |> toFloat) (\_ -> State.ToggleFlashCard) + , Time.every (model.tempo |> Misc.bpmToMilliseconds |> toFloat) (\_ -> State.NextChord) + ] + + +view : State.Model -> Html State.Msg +view model = + case model.view of + State.Preferences -> + Preferences.render model + + State.Practice -> + Practice.render model + + State.Overview -> + Overview.render model + + +main = + Browser.element + { init = \() -> ( State.init, Cmd.none ) + , subscriptions = subscriptions + , update = State.update + , view = view + } diff --git a/users/wpcarro/website/sandbox/learnpianochords/src/Misc.elm b/users/wpcarro/website/sandbox/learnpianochords/src/Misc.elm new file mode 100644 index 0000000000..288d7a825f --- /dev/null +++ b/users/wpcarro/website/sandbox/learnpianochords/src/Misc.elm @@ -0,0 +1,59 @@ +module Misc exposing (..) + +import Array exposing (Array) + + +comesAfter : a -> List a -> Maybe a +comesAfter x xs = + case xs of + [] -> + Nothing + + _ :: [] -> + Nothing + + y :: z :: rest -> + if y == x then + Just z + + else + comesAfter x (z :: rest) + + +comesBefore : a -> List a -> Maybe a +comesBefore x xs = + case xs of + [] -> + Nothing + + _ :: [] -> + Nothing + + y :: z :: rest -> + if z == x then + Just y + + else + comesBefore x (z :: rest) + + +find : (a -> Bool) -> List a -> Maybe a +find pred xs = + case xs |> List.filter pred of + [] -> + Nothing + + x :: _ -> + Just x + + +{-| Return the number of milliseconds that elapse during an interval in a +`target` bpm. +-} +bpmToMilliseconds : Int -> Int +bpmToMilliseconds target = + let + msPerMinute = + 1000 * 60 + in + round (toFloat msPerMinute / toFloat target) diff --git a/users/wpcarro/website/sandbox/learnpianochords/src/Overview.elm b/users/wpcarro/website/sandbox/learnpianochords/src/Overview.elm new file mode 100644 index 0000000000..628b52d79d --- /dev/null +++ b/users/wpcarro/website/sandbox/learnpianochords/src/Overview.elm @@ -0,0 +1,122 @@ +module Overview exposing (render) + +import Html exposing (..) +import Html.Attributes exposing (..) +import Html.Events exposing (..) +import Responsive +import State +import Tailwind +import UI + + +header1 : String -> Html msg +header1 copy = + h2 + [ [ "text-center" + , "pt-24" + , "pb-12" + , Responsive.h1 + ] + |> Tailwind.use + |> class + ] + [ text copy ] + + +header2 : String -> Html msg +header2 copy = + h2 + [ [ "text-center" + , "pb-10" + , Responsive.h2 + ] + |> Tailwind.use + |> class + ] + [ text copy ] + + +paragraph : String -> Html msg +paragraph copy = + p + [ [ "pb-10" + , Responsive.h3 + ] + |> Tailwind.use + |> class + ] + [ text copy ] + + +sect : { title : String, copy : List String } -> Html msg +sect { title, copy } = + section [] (header2 title :: (copy |> List.map paragraph)) + + +numberedList : List String -> Html msg +numberedList items = + ol + [ [ "list-inside" + , "list-decimal" + , Responsive.h3 + ] + |> Tailwind.use + |> class + ] + (items |> List.map (\x -> li [ [ "pb-10" ] |> Tailwind.use |> class ] [ text x ])) + + +render : State.Model -> Html State.Msg +render model = + div [ [ "container", "mx-auto" ] |> Tailwind.use |> class ] + [ header1 "Welcome to LearnPianoChords.app!" + , paragraph """ + Learn Piano Chords helps piano players master chords. + """ + , paragraph """ + Chords are the building blocks songwriters use to create + music. Whether you're a performer or songwriter, you need + to understand chords to unlock your full musical potential. + """ + , paragraph """ + I think that if practicing is enjoyable, students will + practice more. Practice doesn’t make perfect; perfect + practice makes perfect. + """ + , section [] + [ header2 "Ready to get started?" + , numberedList + [ """ + Sit down at the piano. + """ + , """ + Set the tempo at which you would like to practice. + """ + , """ + Select the key or keys in which you would like to + practice. + """ + , """ + When you are ready, close the preferences pane. We will show + you the name of a chord, and you should play that chord on + the piano. + """ + , """ + If you don't know how to play the chord, toggle the piano + viewer to see the notes. + """ + , """ + At any point while you're training, press the screen to pause + or resume your practice. + """ + ] + ] + , div [ [ "text-center", "py-20" ] |> Tailwind.use |> class ] + [ UI.simpleButton + { label = "Let's get started" + , handleClick = State.SetView State.Preferences + , color = UI.Secondary + , classes = [] + } + ] + ] diff --git a/users/wpcarro/website/sandbox/learnpianochords/src/Piano.elm b/users/wpcarro/website/sandbox/learnpianochords/src/Piano.elm new file mode 100644 index 0000000000..d231f14674 --- /dev/null +++ b/users/wpcarro/website/sandbox/learnpianochords/src/Piano.elm @@ -0,0 +1,194 @@ +module Piano exposing (render) + +import Browser +import Html exposing (..) +import Html.Attributes exposing (..) +import Html.Events exposing (..) +import List.Extra +import Theory +import UI + + +type alias KeyMarkup a = + { offset : Int + , isHighlit : Bool + , note : Theory.Note + , isRootNote : Bool + } + -> Html a + + +type alias Props = + { chord : Maybe Theory.Chord + , firstNote : Theory.Note + , lastNote : Theory.Note + } + + +naturalThickness : Int +naturalThickness = + 105 + + +accidentalThickness : Int +accidentalThickness = + round (toFloat naturalThickness / 2.0) + + +{-| Convert an integer into its pixel representation for CSS. +-} +pixelate : Int -> String +pixelate x = + String.fromInt x ++ "px" + + +{-| Return the markup for either a white or a black key. +-} +pianoKey : KeyMarkup a +pianoKey { offset, isHighlit, note, isRootNote } = + let + { natColor, accColor, hiColor, rootColor } = + { natColor = "bg-white" + , accColor = "bg-black" + , hiColor = "bg-red-400" + , rootColor = "bg-red-600" + } + + sharedClasses = + [ "box-border" + , "absolute" + , "border" + , "border-black" + ] + + { keyLength, keyThickness, keyColor, offsetEdge, extraClasses } = + case Theory.keyClass note of + Theory.Natural -> + { keyLength = "w-screen" + , keyThickness = naturalThickness + , keyColor = natColor + , offsetEdge = "top" + , extraClasses = [] + } + + Theory.Accidental -> + { keyLength = "w-2/3" + , keyThickness = accidentalThickness + , keyColor = accColor + , offsetEdge = "top" + , extraClasses = [ "z-10" ] + } + in + div + [ class + (case ( isHighlit, isRootNote ) of + ( False, _ ) -> + keyColor + + ( True, True ) -> + rootColor + + ( True, False ) -> + hiColor + ) + , class keyLength + , style "height" (pixelate keyThickness) + , style offsetEdge (String.fromInt offset ++ "px") + , class <| String.join " " (List.concat [ sharedClasses, extraClasses ]) + ] + [] + + +{-| A section of the piano consisting of all twelve notes. +-} +keys : + { start : Theory.Note + , end : Theory.Note + , highlitNotes : List Theory.Note + , rootNote : Maybe Theory.Note + } + -> List (Html a) +keys { start, end, highlitNotes, rootNote } = + let + isHighlit note = + List.member note highlitNotes + + spacing prevOffset prev curr = + case ( Theory.keyClass prev, Theory.keyClass curr ) of + ( Theory.Natural, Theory.Accidental ) -> + prevOffset + naturalThickness - round (toFloat accidentalThickness / 2) + + ( Theory.Accidental, Theory.Natural ) -> + prevOffset + round (toFloat accidentalThickness / 2) + + ( Theory.Natural, Theory.Natural ) -> + prevOffset + naturalThickness + + -- This pattern should never hit. + _ -> + prevOffset + + ( _, _, notes ) = + Theory.notesFromRange start end + |> List.reverse + |> List.foldl + (\curr ( prevOffset, prev, result ) -> + case ( prevOffset, prev ) of + ( Nothing, Nothing ) -> + ( Just 0 + , Just curr + , pianoKey + { offset = 0 + , isHighlit = List.member curr highlitNotes + , note = curr + , isRootNote = + rootNote + |> Maybe.map (\x -> x == curr) + |> Maybe.withDefault False + } + :: result + ) + + ( Just po, Just p ) -> + let + offset = + spacing po p curr + in + ( Just offset + , Just curr + , pianoKey + { offset = offset + , isHighlit = List.member curr highlitNotes + , note = curr + , isRootNote = + rootNote + |> Maybe.map (\x -> x == curr) + |> Maybe.withDefault False + } + :: result + ) + + -- This pattern should never hit. + _ -> + ( Nothing, Nothing, [] ) + ) + ( Nothing, Nothing, [] ) + in + notes + + +{-| Return the HTML that renders a piano representation. +-} +render : Props -> Html a +render { chord } = + div [ style "display" "flex" ] + (keys + { start = Theory.G3 + , end = Theory.C6 + , rootNote = chord |> Maybe.map .note + , highlitNotes = + chord + |> Maybe.andThen Theory.notesForChord + |> Maybe.withDefault [] + } + ) diff --git a/users/wpcarro/website/sandbox/learnpianochords/src/Practice.elm b/users/wpcarro/website/sandbox/learnpianochords/src/Practice.elm new file mode 100644 index 0000000000..5d87bcee50 --- /dev/null +++ b/users/wpcarro/website/sandbox/learnpianochords/src/Practice.elm @@ -0,0 +1,61 @@ +module Practice exposing (render) + +import FlashCard +import Html exposing (..) +import Html.Attributes exposing (..) +import Html.Events exposing (..) +import Icon +import Piano +import State +import Tailwind +import Theory +import UI + + +openPreferences : Html State.Msg +openPreferences = + button + [ class "w-48 h-48 absolute left-0 top-0 z-50" + , onClick (State.SetView State.Preferences) + ] + [ Icon.cog ] + + +render : State.Model -> Html State.Msg +render model = + let + ( handleClick, buttonText ) = + if model.isPaused then + ( State.Play, "Tap to practice" ) + + else + ( State.Pause, "" ) + in + div [] + [ openPreferences + , case model.selectedChord of + Just chord -> + FlashCard.render + { chord = chord + , visible = model.showFlashCard + } + + Nothing -> + -- Here I'm abusing the overlayButton component to render text + -- horizontally. I should support a UI component for this. + UI.overlayButton + { label = "Get ready..." + , handleClick = State.DoNothing + , isVisible = True + } + , UI.overlayButton + { label = buttonText + , handleClick = handleClick + , isVisible = model.isPaused + } + , Piano.render + { chord = model.selectedChord + , firstNote = model.firstNote + , lastNote = model.lastNote + } + ] diff --git a/users/wpcarro/website/sandbox/learnpianochords/src/Preferences.elm b/users/wpcarro/website/sandbox/learnpianochords/src/Preferences.elm new file mode 100644 index 0000000000..59e6c8234c --- /dev/null +++ b/users/wpcarro/website/sandbox/learnpianochords/src/Preferences.elm @@ -0,0 +1,148 @@ +module Preferences exposing (render) + +import Html exposing (..) +import Html.Attributes exposing (..) +import Html.Events exposing (..) +import Icon +import Responsive +import State +import Tailwind +import Tempo +import Theory +import UI + + +selectKey : + State.Model + -> + { relativeMajor : Theory.Key + , relativeMinor : Theory.Key + } + -> Html State.Msg +selectKey model { relativeMajor, relativeMinor } = + let + active key = + List.member key model.whitelistedKeys + + buttonLabel major minor = + Theory.viewKey major ++ ", " ++ Theory.viewKey minor + in + div [ class "flex pt-0" ] + [ UI.textToggleButton + { label = buttonLabel relativeMajor relativeMinor + , handleClick = State.ToggleKey relativeMajor + , classes = [ "flex-1" ] + , toggled = active relativeMajor + } + ] + + +inversionCheckboxes : State.Model -> Html State.Msg +inversionCheckboxes model = + div [] + [ h2 + [ [ "text-gray-500" + , "text-center" + , "pt-10" + , Responsive.h2 + ] + |> Tailwind.use + |> class + ] + [ text "Select inversions" ] + , ul + [ [ "flex", "justify-center" ] |> Tailwind.use |> class ] + (Theory.allInversions + |> List.map + (\inversion -> + li [] + [ UI.textToggleButton + { label = Theory.inversionName inversion + , handleClick = State.ToggleInversion inversion + , classes = [] + , toggled = List.member inversion model.whitelistedInversions + } + ] + ) + ) + ] + + +keyCheckboxes : State.Model -> Html State.Msg +keyCheckboxes model = + let + majorKey pitchClass = + { pitchClass = pitchClass, mode = Theory.MajorMode } + + minorKey pitchClass = + { pitchClass = pitchClass, mode = Theory.MinorMode } + + circleOfFifths = + [ ( Theory.C, Theory.A ) + , ( Theory.G, Theory.E ) + , ( Theory.D, Theory.B ) + , ( Theory.A, Theory.F_sharp ) + , ( Theory.E, Theory.C_sharp ) + , ( Theory.B, Theory.G_sharp ) + , ( Theory.F_sharp, Theory.D_sharp ) + , ( Theory.C_sharp, Theory.A_sharp ) + , ( Theory.G_sharp, Theory.F ) + , ( Theory.D_sharp, Theory.C ) + , ( Theory.A_sharp, Theory.G ) + , ( Theory.F, Theory.D ) + ] + in + div [] + [ h2 + [ [ "text-gray-500" + , "text-center" + , "pt-10" + , Responsive.h2 + ] + |> Tailwind.use + |> class + ] + [ text "Select keys" ] + , ul [] + (circleOfFifths + |> List.map + (\( major, minor ) -> + selectKey model + { relativeMajor = majorKey major + , relativeMinor = minorKey minor + } + ) + ) + ] + + +closePreferences : Html State.Msg +closePreferences = + button + [ [ "w-48" + , "lg:w-32" + , "h-48" + , "lg:h-32" + , "absolute" + , "right-0" + , "top-0" + , "z-10" + ] + |> Tailwind.use + |> class + , onClick (State.SetView State.Practice) + ] + [ Icon.close ] + + +render : State.Model -> Html State.Msg +render model = + div [ class "pt-10 pb-20 px-10" ] + [ closePreferences + , Tempo.render + { tempo = model.tempo + , handleInput = State.SetTempo + } + , inversionCheckboxes model + , keyCheckboxes model + ] diff --git a/users/wpcarro/website/sandbox/learnpianochords/src/Responsive.elm b/users/wpcarro/website/sandbox/learnpianochords/src/Responsive.elm new file mode 100644 index 0000000000..5d97161df6 --- /dev/null +++ b/users/wpcarro/website/sandbox/learnpianochords/src/Responsive.elm @@ -0,0 +1,19 @@ +module Responsive exposing (..) + +{-| Returns a string containing all of the Tailwind selectors we use to size +h2-sized elements across various devices. -} +h1 : String +h1 = + "text-6xl lg:text-4xl" + +{-| Returns a string containing all of the Tailwind selectors we use to size +h2-sized elements across various devices. -} +h2 : String +h2 = + "text-5xl lg:text-3xl" + +{-| Returns a string containing all of the Tailwind selectors we use to size +h3-sized elements across various devices. -} +h3 : String +h3 = + "text-4xl lg:text-2xl" diff --git a/users/wpcarro/website/sandbox/learnpianochords/src/State.elm b/users/wpcarro/website/sandbox/learnpianochords/src/State.elm new file mode 100644 index 0000000000..678fb0f9aa --- /dev/null +++ b/users/wpcarro/website/sandbox/learnpianochords/src/State.elm @@ -0,0 +1,179 @@ +module State exposing (..) + +import Random +import Random.List +import Theory + + +type Msg + = NextChord + | NewChord Theory.Chord + | Play + | Pause + | SetTempo String + | ToggleInversion Theory.ChordInversion + | ToggleKey Theory.Key + | DoNothing + | SetView View + | ToggleFlashCard + + +type View + = Preferences + | Practice + | Overview + + +type alias Model = + { whitelistedChords : List Theory.Chord + , whitelistedChordTypes : List Theory.ChordType + , whitelistedInversions : List Theory.ChordInversion + , whitelistedPitchClasses : List Theory.PitchClass + , whitelistedKeys : List Theory.Key + , selectedChord : Maybe Theory.Chord + , isPaused : Bool + , tempo : Int + , firstNote : Theory.Note + , lastNote : Theory.Note + , view : View + , showFlashCard : Bool + } + + +{-| The initial state for the application. +-} +init : Model +init = + let + ( firstNote, lastNote ) = + ( Theory.C3, Theory.C6 ) + + inversions = + [ Theory.Root ] + + chordTypes = + Theory.allChordTypes + + pitchClasses = + Theory.allPitchClasses + + keys = + [ { pitchClass = Theory.C, mode = Theory.MajorMode } ] + in + { whitelistedChords = + keys + |> List.concatMap Theory.chordsForKey + |> List.filter (\chord -> List.member chord.chordInversion inversions) + , whitelistedChordTypes = chordTypes + , whitelistedInversions = inversions + , whitelistedPitchClasses = pitchClasses + , whitelistedKeys = keys + , selectedChord = Nothing + , isPaused = True + , tempo = 10 + , firstNote = firstNote + , lastNote = lastNote + , view = Overview + , showFlashCard = True + } + + +{-| Now that we have state, we need a function to change the state. +-} +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg model = + case msg of + DoNothing -> + ( model, Cmd.none ) + + SetView x -> + ( { model + | view = x + , isPaused = True + } + , Cmd.none + ) + + NewChord chord -> + ( { model | selectedChord = Just chord } + , Cmd.none + ) + + NextChord -> + ( model + , Random.generate + (\x -> + case x of + ( Just chord, _ ) -> + NewChord chord + + ( Nothing, _ ) -> + DoNothing + ) + (Random.List.choose model.whitelistedChords) + ) + + Play -> + ( { model | isPaused = False } + , Cmd.none + ) + + Pause -> + ( { model | isPaused = True } + , Cmd.none + ) + + ToggleInversion inversion -> + let + inversions = + if List.member inversion model.whitelistedInversions then + List.filter ((/=) inversion) model.whitelistedInversions + + else + inversion :: model.whitelistedInversions + in + ( { model + | whitelistedInversions = inversions + , whitelistedChords = + model.whitelistedKeys + |> List.concatMap Theory.chordsForKey + |> List.filter (\chord -> List.member chord.chordInversion inversions) + } + , Cmd.none + ) + + ToggleKey key -> + let + keys = + if List.member key model.whitelistedKeys then + List.filter ((/=) key) model.whitelistedKeys + + else + key :: model.whitelistedKeys + in + ( { model + | whitelistedKeys = keys + , whitelistedChords = + keys + |> List.concatMap Theory.chordsForKey + |> List.filter (\chord -> List.member chord.chordInversion model.whitelistedInversions) + , selectedChord = Nothing + } + , Cmd.none + ) + + SetTempo tempo -> + ( { model + | tempo = + case String.toInt tempo of + Just x -> + x + + Nothing -> + model.tempo + } + , Cmd.none + ) + + ToggleFlashCard -> + ( { model | showFlashCard = not model.showFlashCard }, Cmd.none ) diff --git a/users/wpcarro/website/sandbox/learnpianochords/src/Tailwind.elm b/users/wpcarro/website/sandbox/learnpianochords/src/Tailwind.elm new file mode 100644 index 0000000000..57d419db5a --- /dev/null +++ b/users/wpcarro/website/sandbox/learnpianochords/src/Tailwind.elm @@ -0,0 +1,29 @@ +module Tailwind exposing (..) + +{-| Functions to make Tailwind development in Elm even more pleasant. +-} + + +{-| Conditionally use `class` selection when `condition` is true. +-} +when : Bool -> String -> String +when condition class = + if condition then + class + + else + "" + + +if_ : Bool -> String -> String -> String +if_ condition whenTrue whenFalse = + if condition then + whenTrue + + else + whenFalse + + +use : List String -> String +use styles = + String.join " " styles diff --git a/users/wpcarro/website/sandbox/learnpianochords/src/Tempo.elm b/users/wpcarro/website/sandbox/learnpianochords/src/Tempo.elm new file mode 100644 index 0000000000..041313614f --- /dev/null +++ b/users/wpcarro/website/sandbox/learnpianochords/src/Tempo.elm @@ -0,0 +1,33 @@ +module Tempo exposing (render) + +import Html exposing (..) +import Html.Attributes exposing (..) +import Html.Events exposing (..) +import Responsive +import Tailwind +import UI + + +type alias Props msg = + { tempo : Int + , handleInput : String -> msg + } + + +render : Props msg -> Html msg +render { tempo, handleInput } = + div [ class "text-center" ] + [ p + [ [ "py-10" + , Responsive.h2 + ] + |> Tailwind.use + |> class + ] + [ text (String.fromInt tempo ++ " BPM") ] + , UI.textField + { placeholderText = "Set tempo..." + , handleInput = handleInput + , classes = [] + } + ] diff --git a/users/wpcarro/website/sandbox/learnpianochords/src/Theory.elm b/users/wpcarro/website/sandbox/learnpianochords/src/Theory.elm new file mode 100644 index 0000000000..7f54832c97 --- /dev/null +++ b/users/wpcarro/website/sandbox/learnpianochords/src/Theory.elm @@ -0,0 +1,1100 @@ +module Theory exposing (..) + +import Array exposing (Array) +import Dict exposing (Dict) +import List.Extra +import Maybe.Extra +import Misc + + +{-| Notes are the individuals sounds that we use to create music. Think: "do re +mi fa so la ti do". + +Note: Technically a "C-sharp" is also a "D-flat", but I will model accidentals +(i.e. sharps and flats) as sharps and represent the ambiguity when I render the +underlying state of the application. + +Note: There are "notes" like A, B, D-flat, and then there are notes like "middle +C", also denoted in scientific pitch notation as C4. I'm unsure of what to call +each of these, and my application does not model scientific pitch notation yet, +so these non-scientific pitch denote values are "notes" for now. + +-} +type Note + = C1 + | C_sharp1 + | D1 + | D_sharp1 + | E1 + | F1 + | F_sharp1 + | G1 + | G_sharp1 + | A1 + | A_sharp1 + | B1 + | C2 + | C_sharp2 + | D2 + | D_sharp2 + | E2 + | F2 + | F_sharp2 + | G2 + | G_sharp2 + | A2 + | A_sharp2 + | B2 + | C3 + | C_sharp3 + | D3 + | D_sharp3 + | E3 + | F3 + | F_sharp3 + | G3 + | G_sharp3 + | A3 + | A_sharp3 + | B3 + | C4 + | C_sharp4 + | D4 + | D_sharp4 + | E4 + | F4 + | F_sharp4 + | G4 + | G_sharp4 + | A4 + | A_sharp4 + | B4 + | C5 + | C_sharp5 + | D5 + | D_sharp5 + | E5 + | F5 + | F_sharp5 + | G5 + | G_sharp5 + | A5 + | A_sharp5 + | B5 + | C6 + | C_sharp6 + | D6 + | D_sharp6 + | E6 + | F6 + | F_sharp6 + | G6 + | G_sharp6 + | A6 + | A_sharp6 + | B6 + | C7 + | C_sharp7 + | D7 + | D_sharp7 + | E7 + | F7 + | F_sharp7 + | G7 + | G_sharp7 + | A7 + | A_sharp7 + | B7 + | C8 + + +{-| I alluded to this concept in the Note type's documentation. These are the +letters of notes. For instance C2, C3, C4 are all instances of C. +-} +type PitchClass + = C + | C_sharp + | D + | D_sharp + | E + | F + | F_sharp + | G + | G_sharp + | A + | A_sharp + | B + + +{-| Encode whether you are traversing "up" or "down" intervals +-} +type StepDirection + = Up + | Down + + +{-| One can measure the difference between between notes using intervals. +-} +type Interval + = Half + | NHalves Int + | Whole + | MajorThird + | MinorThird + | PerfectFifth + | AugmentedFifth + | DiminishedFifth + | MajorSeventh + | DominantSeventh + + +{-| Add direction to a distance on the piano. +-} +type alias IntervalVector = + { interval : Interval + , direction : StepDirection + } + + +{-| A bundle of notes which are usually, but not necessarily harmonious. +-} +type alias Chord = + { note : Note + , chordType : ChordType + , chordInversion : ChordInversion + } + + +{-| Many possible chords exist. This type encodes the possibilities. I am +tempted to model these in a more "DRY" way, but I worry that this abstraction +may cause more problems than it solves. +-} +type ChordType + = Major + | Sus2 + | Sus4 + | Major7 + | MajorDominant7 + | Minor + | MinorMajor7 + | MinorDominant7 + | Augmented + | AugmentedDominant7 + | Diminished + | DiminishedDominant7 + | DiminishedMajor7 + + +{-| On a piano, a triad can be played three ways. As a rule-of-thumb, The number +of ways a pianist can play a chord is equal to the number of notes in the chord +itself. +-} +type ChordInversion + = Root + | First + | Second + + +{-| Whether a given note is a white key or a black key. +-} +type KeyClass + = Natural + | Accidental + + +{-| Songs are written in one or more keys, which define the notes and therefore +chords that harmonize with one another. +-} +type alias Key = + { pitchClass : PitchClass + , mode : Mode + } + + +{-| We create "scales" by enumerating the notes of a given key. These keys are +defined by the "tonic" note and the "mode". I thought about including Ionian, +Dorian, Phrygian, etc., but in the I would like to avoid over-abstracting this +early on, so I'm going to err on the side of overly concrete until I have a +better idea of the extent of this project. +-} +type Mode + = BluesMode + | MajorMode + | MinorMode + + +type alias NoteMetadata = + { note : Note + , label : String + , pitchClass : PitchClass + , natural : Bool + } + + +{-| An integer representing which note in a given scale to play. +-} +type alias ScaleDegree = + Int + + +{-| Returns the Note in the cental octave of the piano for a given +PitchClass. For example, C4 -- or "middle C" -- for C. +-} +noteInCentralOctave : PitchClass -> Note +noteInCentralOctave pitchClass = + case pitchClass of + C -> + C4 + + C_sharp -> + C_sharp4 + + D -> + D4 + + D_sharp -> + D_sharp4 + + E -> + E4 + + F -> + F4 + + F_sharp -> + F_sharp4 + + G -> + G4 + + G_sharp -> + G_sharp4 + + A -> + A4 + + A_sharp -> + A_sharp4 + + B -> + B4 + + +{-| Return the human-readable version of a chord inversion. +-} +inversionName : ChordInversion -> String +inversionName inversion = + case inversion of + Root -> + "Root" + + First -> + "First" + + Second -> + "Second" + + +{-| Return the human-readable version of a chord type. +-} +chordTypeName : ChordType -> String +chordTypeName chordType = + case chordType of + Major -> + "major" + + Sus2 -> + "suspended 2" + + Sus4 -> + "suspended 4" + + Major7 -> + "major 7th" + + MajorDominant7 -> + "major dominant 7th" + + Minor -> + "minor" + + MinorMajor7 -> + "minor major 7th" + + MinorDominant7 -> + "minor dominant 7th" + + Augmented -> + "augmented" + + AugmentedDominant7 -> + "augmented dominant 7th" + + Diminished -> + "diminished" + + DiminishedDominant7 -> + "diminished dominant 7th" + + DiminishedMajor7 -> + "diminished major 7th" + + +{-| Return the note that is one half step away from `note` in the direction, +`dir`. +In the case of stepping up or down from the end of the piano, this returns a +Maybe. +-} +halfStep : StepDirection -> Note -> Maybe Note +halfStep dir note = + let + everyNote = + notesFromRange C2 C8 + in + case dir of + Up -> + Misc.comesAfter note everyNote + + Down -> + Misc.comesBefore note everyNote + + +{-| Return a list of steps to take away from the root note to return back to the +root note for a given mode. +-} +intervalsForMode : Mode -> List IntervalVector +intervalsForMode mode = + let + up x = + { direction = Up, interval = x } + + down x = + { direction = Down, interval = x } + in + case mode of + MajorMode -> + List.map up [ Whole, Whole, Half, Whole, Whole, Whole ] + + MinorMode -> + List.map up [ Whole, Half, Whole, Whole, Half, Whole ] + + BluesMode -> + List.map up [ MinorThird, Whole, Half, Half, MinorThird ] + + +{-| Return a list of the intervals that a chord. Each interval measures +the distance away from the root-note of the chord. +-} +intervalsForChordType : ChordType -> ChordInversion -> List IntervalVector +intervalsForChordType chordType chordInversion = + let + up x = + { direction = Up, interval = x } + + down x = + { direction = Down, interval = x } + in + case ( chordType, chordInversion ) of + -- Major + ( Major, Root ) -> + [ up MajorThird, up PerfectFifth ] + + ( Major, First ) -> + [ down (NHalves 5), down (NHalves 8) ] + + ( Major, Second ) -> + [ down (NHalves 5), up MajorThird ] + + -- Sus2 + ( Sus2, Root ) -> + [ up Whole, up PerfectFifth ] + + ( Sus2, First ) -> + [ down (NHalves 10), down (NHalves 5) ] + + ( Sus2, Second ) -> + [ down (NHalves 5), up Whole ] + + -- Sus4 + ( Sus4, Root ) -> + [ up (NHalves 5), up PerfectFifth ] + + ( Sus4, First ) -> + [ down (NHalves 7), down (NHalves 5) ] + + ( Sus4, Second ) -> + [ down (NHalves 5), up (NHalves 5) ] + + -- Major7 + ( Major7, Root ) -> + [ up MajorThird, up PerfectFifth, up MajorSeventh ] + + ( Major7, First ) -> + down Half :: intervalsForChordType Major chordInversion + + ( Major7, Second ) -> + down Half :: intervalsForChordType Major chordInversion + + -- MajorDominant7 + ( MajorDominant7, Root ) -> + up DominantSeventh :: intervalsForChordType Major chordInversion + + ( MajorDominant7, First ) -> + down Whole :: intervalsForChordType Major chordInversion + + ( MajorDominant7, Second ) -> + down Whole :: intervalsForChordType Major chordInversion + + -- Minor + ( Minor, Root ) -> + [ up MinorThird, up PerfectFifth ] + + ( Minor, First ) -> + [ down (NHalves 5), down (NHalves 9) ] + + ( Minor, Second ) -> + [ down (NHalves 5), up MinorThird ] + + -- MinorMajor7 + ( MinorMajor7, Root ) -> + up MajorSeventh :: intervalsForChordType Minor chordInversion + + ( MinorMajor7, First ) -> + down Half :: intervalsForChordType Minor chordInversion + + ( MinorMajor7, Second ) -> + down Half :: intervalsForChordType Minor chordInversion + + -- MinorDominant7 + ( MinorDominant7, Root ) -> + up DominantSeventh :: intervalsForChordType Minor chordInversion + + ( MinorDominant7, First ) -> + down Whole :: intervalsForChordType Minor chordInversion + + ( MinorDominant7, Second ) -> + down Whole :: intervalsForChordType Minor chordInversion + + -- Augmented + ( Augmented, Root ) -> + [ up MajorThird, up AugmentedFifth ] + + ( Augmented, First ) -> + [ down (NHalves 8), down (NHalves 4) ] + + ( Augmented, Second ) -> + [ down (NHalves 4), up MajorThird ] + + -- AugmentedDominant7 + ( AugmentedDominant7, Root ) -> + up DominantSeventh :: intervalsForChordType Augmented chordInversion + + ( AugmentedDominant7, First ) -> + down Whole :: intervalsForChordType Augmented chordInversion + + ( AugmentedDominant7, Second ) -> + down Whole :: intervalsForChordType Augmented chordInversion + + -- Diminished + ( Diminished, Root ) -> + [ up MinorThird, up DiminishedFifth ] + + ( Diminished, First ) -> + [ down (NHalves 6), down (NHalves 9) ] + + ( Diminished, Second ) -> + [ down (NHalves 6), up MinorThird ] + + -- DiminishedDominant7 + ( DiminishedDominant7, Root ) -> + up DominantSeventh :: intervalsForChordType Diminished chordInversion + + ( DiminishedDominant7, First ) -> + down Whole :: intervalsForChordType Diminished chordInversion + + ( DiminishedDominant7, Second ) -> + down Whole :: intervalsForChordType Diminished chordInversion + + -- DiminishedMajor7 + ( DiminishedMajor7, Root ) -> + up MajorSeventh :: intervalsForChordType Diminished chordInversion + + ( DiminishedMajor7, First ) -> + down Half :: intervalsForChordType Diminished chordInversion + + ( DiminishedMajor7, Second ) -> + down Half :: intervalsForChordType Diminished chordInversion + + +{-| Return the note in the direction, `dir`, away from `note` `s` intervals +-} +step : IntervalVector -> Note -> Maybe Note +step { direction, interval } note = + let + doStep int = + step { direction = direction, interval = int } + in + case interval of + Half -> + halfStep direction note + + NHalves n -> + List.repeat n + { direction = direction + , interval = Half + } + |> (\x -> walkNotes x note) + |> Maybe.andThen (List.reverse >> List.head) + + Whole -> + note + |> doStep Half + |> Maybe.andThen (doStep Half) + + MinorThird -> + note + |> doStep Whole + |> Maybe.andThen (doStep Half) + + MajorThird -> + note + |> doStep Whole + |> Maybe.andThen (doStep Whole) + + PerfectFifth -> + note + |> doStep MajorThird + |> Maybe.andThen (doStep MinorThird) + + AugmentedFifth -> + note + |> doStep PerfectFifth + |> Maybe.andThen (doStep Half) + + DiminishedFifth -> + note + |> doStep MajorThird + |> Maybe.andThen (doStep Whole) + + MajorSeventh -> + note + |> doStep PerfectFifth + |> Maybe.andThen (doStep MajorThird) + + DominantSeventh -> + note + |> doStep PerfectFifth + |> Maybe.andThen (doStep MinorThird) + + +{-| Returns a list of all of the notes away from a give `note`. + + - The 0th element is applied to `note`. + - The 1st element is applied to the result of the previous operation. + - The 2nd element is applied to the result of the previous operation. + - and so on...until all of the `steps` are exhausted. + +In the case where applying any of the steps would result in running off of +either edge of the piano, this function returns a Nothing. + +-} +walkNotes : List IntervalVector -> Note -> Maybe (List Note) +walkNotes steps note = + doWalkNotes steps note [] |> Maybe.map List.reverse + + +{-| Recursive helper for `walkNotes`. +-} +doWalkNotes : List IntervalVector -> Note -> List Note -> Maybe (List Note) +doWalkNotes steps note result = + case steps of + [] -> + Just (note :: result) + + s :: rest -> + case step s note of + Just x -> + doWalkNotes rest x (note :: result) + + Nothing -> + Nothing + + +{-| Return the KeyClass for a given `note`. +-} +keyClass : Note -> KeyClass +keyClass note = + if isNatural note then + Natural + + else + Accidental + + +{-| Return the PitchClass for a given note. +-} +classifyNote : Note -> PitchClass +classifyNote note = + note |> getNoteMetadata |> .pitchClass + + +{-| Return a list of the notes that comprise a `chord` +-} +notesForChord : Chord -> Maybe (List Note) +notesForChord { note, chordType, chordInversion } = + intervalsForChordType chordType chordInversion + |> List.map (\interval -> step interval note) + |> Maybe.Extra.combine + |> Maybe.map (\notes -> note :: notes) + + +{-| Return the scale for a given `key`. +-} +notesForKey : Key -> List Note +notesForKey { pitchClass, mode } = + let + origin = + noteInCentralOctave pitchClass + in + case walkNotes (intervalsForMode mode) origin of + -- We should never hit the Nothing case here. + Nothing -> + [] + + Just scale -> + scale + + +{-| Return true if `note` is a black key. +-} +isAccidental : Note -> Bool +isAccidental note = + note |> isNatural |> not + + +{-| Return true if `note` is a white key. +-} +isNatural : Note -> Bool +isNatural note = + note |> getNoteMetadata |> .natural + + +{-| Return a list of all of the notes that we know about. +Only return the notes within the range `start` and `end`. +-} +notesFromRange : Note -> Note -> List Note +notesFromRange start end = + noteMetadata + |> Array.toList + |> List.map .note + |> List.Extra.dropWhile ((/=) start) + |> List.Extra.takeWhile ((/=) end) + + +{-| Return a list of all of the chord inversions about which we know. +-} +allInversions : List ChordInversion +allInversions = + [ Root, First, Second ] + + +{-| Return a list of all of the chord types about which we know. +-} +allChordTypes : List ChordType +allChordTypes = + [ Major + , Sus2 + , Sus4 + , Major7 + , MajorDominant7 + , Minor + , MinorMajor7 + , MinorDominant7 + , Augmented + , AugmentedDominant7 + , Diminished + , DiminishedDominant7 + , DiminishedMajor7 + ] + + +{-| Return a list of all of the key modes about which we know. +-} +allModes : List Mode +allModes = + [ MajorMode, MinorMode, BluesMode ] + + +{-| Return a list of all of the keys about which we know. +-} +allKeys : List Key +allKeys = + allPitchClasses + |> List.Extra.andThen + (\pitchClass -> + allModes + |> List.Extra.andThen + (\mode -> + [ { pitchClass = pitchClass + , mode = mode + } + ] + ) + ) + + +{-| Return an array of every note on a piano. +Note: Currently this piano has 85 keys, but modern pianos have 88 keys. I would +prefer to have 88 keys, but it's not urgent. +-} +noteMetadata : Array NoteMetadata +noteMetadata = + Array.fromList + [ { note = A1, label = "A1", pitchClass = A, natural = True } + , { note = A_sharp1, label = "A♯/B♭1", pitchClass = A_sharp, natural = False } + , { note = B1, label = "B1", pitchClass = B, natural = True } + , { note = C1, label = "C1", pitchClass = C, natural = True } + , { note = C_sharp1, label = "C♯/D♭1", pitchClass = C_sharp, natural = False } + , { note = D1, label = "D1", pitchClass = D, natural = True } + , { note = D_sharp1, label = "D♯/E♭1", pitchClass = D_sharp, natural = False } + , { note = E1, label = "E1", pitchClass = E, natural = True } + , { note = F1, label = "F1", pitchClass = F, natural = True } + , { note = F_sharp1, label = "F♯/G♭1", pitchClass = F_sharp, natural = False } + , { note = G1, label = "G1", pitchClass = G, natural = True } + , { note = G_sharp1, label = "G♯/A♭1", pitchClass = G_sharp, natural = False } + , { note = A2, label = "A2", pitchClass = A, natural = True } + , { note = A_sharp2, label = "A♯/B♭2", pitchClass = A_sharp, natural = False } + , { note = B2, label = "B2", pitchClass = B, natural = True } + , { note = C2, label = "C2", pitchClass = C, natural = True } + , { note = C_sharp2, label = "C♯/D♭2", pitchClass = C_sharp, natural = False } + , { note = D2, label = "D2", pitchClass = D, natural = True } + , { note = D_sharp2, label = "D♯/E♭2", pitchClass = D_sharp, natural = False } + , { note = E2, label = "E2", pitchClass = E, natural = True } + , { note = F2, label = "F2", pitchClass = F, natural = True } + , { note = F_sharp2, label = "F♯/G♭2", pitchClass = F_sharp, natural = False } + , { note = G2, label = "G2", pitchClass = G, natural = True } + , { note = G_sharp2, label = "G♯/A♭2", pitchClass = G_sharp, natural = False } + , { note = A3, label = "A3", pitchClass = A, natural = True } + , { note = A_sharp3, label = "A♯/B♭3", pitchClass = A_sharp, natural = False } + , { note = B3, label = "B3", pitchClass = B, natural = True } + , { note = C3, label = "C3", pitchClass = C, natural = True } + , { note = C_sharp3, label = "C♯/D♭3", pitchClass = C_sharp, natural = False } + , { note = D3, label = "D3", pitchClass = D, natural = True } + , { note = D_sharp3, label = "D♯/E♭3", pitchClass = D_sharp, natural = False } + , { note = E3, label = "E3", pitchClass = E, natural = True } + , { note = F3, label = "F3", pitchClass = F, natural = True } + , { note = F_sharp3, label = "F♯/G♭3", pitchClass = F_sharp, natural = False } + , { note = G3, label = "G3", pitchClass = G, natural = True } + , { note = G_sharp3, label = "G♯/A♭3", pitchClass = G_sharp, natural = False } + , { note = A4, label = "A4", pitchClass = A, natural = True } + , { note = A_sharp4, label = "A♯/B♭4", pitchClass = A_sharp, natural = False } + , { note = B4, label = "B4", pitchClass = B, natural = True } + , { note = C4, label = "C4", pitchClass = C, natural = True } + , { note = C_sharp4, label = "C♯/D♭4", pitchClass = C_sharp, natural = False } + , { note = D4, label = "D4", pitchClass = D, natural = True } + , { note = D_sharp4, label = "D♯/E♭4", pitchClass = D_sharp, natural = False } + , { note = E4, label = "E4", pitchClass = E, natural = True } + , { note = F4, label = "F4", pitchClass = F, natural = True } + , { note = F_sharp4, label = "F♯/G♭4", pitchClass = F_sharp, natural = False } + , { note = G4, label = "G4", pitchClass = G, natural = True } + , { note = G_sharp4, label = "G♯/A♭4", pitchClass = G_sharp, natural = False } + , { note = A5, label = "A5", pitchClass = A, natural = True } + , { note = A_sharp5, label = "A♯/B♭5", pitchClass = A_sharp, natural = False } + , { note = B5, label = "B5", pitchClass = B, natural = True } + , { note = C5, label = "C5", pitchClass = C, natural = True } + , { note = C_sharp5, label = "C♯/D♭5", pitchClass = C_sharp, natural = False } + , { note = D5, label = "D5", pitchClass = D, natural = True } + , { note = D_sharp5, label = "D♯/E♭5", pitchClass = D_sharp, natural = False } + , { note = E5, label = "E5", pitchClass = E, natural = True } + , { note = F5, label = "F5", pitchClass = F, natural = True } + , { note = F_sharp5, label = "F♯/G♭5", pitchClass = F_sharp, natural = False } + , { note = G5, label = "G5", pitchClass = G, natural = True } + , { note = G_sharp5, label = "G♯/A♭5", pitchClass = G_sharp, natural = False } + , { note = A6, label = "A6", pitchClass = A, natural = True } + , { note = A_sharp6, label = "A♯/B♭6", pitchClass = A_sharp, natural = False } + , { note = B6, label = "B6", pitchClass = B, natural = True } + , { note = C6, label = "C6", pitchClass = C, natural = True } + , { note = C_sharp6, label = "C♯/D♭6", pitchClass = C_sharp, natural = False } + , { note = D6, label = "D6", pitchClass = D, natural = True } + , { note = D_sharp6, label = "D♯/E♭6", pitchClass = D_sharp, natural = False } + , { note = E6, label = "E6", pitchClass = E, natural = True } + , { note = F6, label = "F6", pitchClass = F, natural = True } + , { note = F_sharp6, label = "F♯/G♭6", pitchClass = F_sharp, natural = False } + , { note = G6, label = "G6", pitchClass = G, natural = True } + , { note = G_sharp6, label = "G♯/A♭6", pitchClass = G_sharp, natural = False } + , { note = A7, label = "A7", pitchClass = A, natural = True } + , { note = A_sharp7, label = "A♯/B♭7", pitchClass = A_sharp, natural = False } + , { note = B7, label = "B7", pitchClass = B, natural = True } + , { note = C7, label = "C7", pitchClass = C, natural = True } + , { note = C_sharp7, label = "C♯/D♭7", pitchClass = C_sharp, natural = False } + , { note = D7, label = "D7", pitchClass = D, natural = True } + , { note = D_sharp7, label = "D♯/E♭7", pitchClass = D_sharp, natural = False } + , { note = E7, label = "E7", pitchClass = E, natural = True } + , { note = F7, label = "F7", pitchClass = F, natural = True } + , { note = F_sharp7, label = "F♯/G♭7", pitchClass = F_sharp, natural = False } + , { note = G7, label = "G7", pitchClass = G, natural = True } + , { note = G_sharp7, label = "G♯/A♭7", pitchClass = G_sharp, natural = False } + , { note = C8, label = "C8", pitchClass = C, natural = True } + ] + + +{-| Mapping of note data to commonly needed metadata for that note. +-} +getNoteMetadata : Note -> NoteMetadata +getNoteMetadata note = + case Array.get (noteAsNumber note) noteMetadata of + Just metadata -> + metadata + + -- This case should never hit, so we just return C1 to appease the + -- compiler. + Nothing -> + getNoteMetadata C1 + + +{-| Return the numeric representation of `note` to ues when comparing two +notes. +-} +noteAsNumber : Note -> Int +noteAsNumber note = + let + result = + noteMetadata + |> Array.toList + |> List.indexedMap Tuple.pair + |> Misc.find (\( _, x ) -> x.note == note) + in + case result of + Nothing -> + 0 + + Just ( i, _ ) -> + i + + +{-| Return true if all of the notes that comprise `chord` can be played on a +piano whose keys begin at `start` and end at `end`. +-} +chordWithinRange : Note -> Note -> Chord -> Bool +chordWithinRange start end chord = + case notesForChord chord of + Just notes -> + let + nums = + List.map noteAsNumber notes + + lo = + List.minimum nums |> Maybe.withDefault (noteAsNumber start) + + hi = + List.maximum nums |> Maybe.withDefault (noteAsNumber end) + in + lo >= noteAsNumber start && hi < noteAsNumber end + + Nothing -> + False + + +{-| Return a list of all of the pitch classes that we know about. +-} +allPitchClasses : List PitchClass +allPitchClasses = + [ C + , C_sharp + , D + , D_sharp + , E + , F + , F_sharp + , G + , G_sharp + , A + , A_sharp + , B + ] + + +{-| Return a list of all of the chords that we know about. +Only create chords from the range of notes delimited by the range `start` and +`end`. +-} +allChords : + { start : Note + , end : Note + , inversions : List ChordInversion + , chordTypes : List ChordType + , pitchClasses : List PitchClass + } + -> List Chord +allChords { start, end, inversions, chordTypes, pitchClasses } = + let + notes = + notesFromRange start end + |> List.filter (\note -> List.member (classifyNote note) pitchClasses) + in + notes + |> List.Extra.andThen + (\note -> + chordTypes + |> List.Extra.andThen + (\chordType -> + inversions + |> List.Extra.andThen + (\inversion -> + [ { note = note + , chordType = chordType + , chordInversion = inversion + } + ] + ) + ) + ) + |> List.filter (chordWithinRange start end) + + +{-| Return a human-readable format of `note`. +-} +viewNote : Note -> String +viewNote note = + note |> getNoteMetadata |> .label + + +{-| Return a human-readable format of `chord`. +-} +viewChord : Chord -> String +viewChord { note, chordType, chordInversion } = + viewPitchClass (classifyNote note) ++ " " ++ chordTypeName chordType ++ " " ++ inversionName chordInversion ++ " position" + + +{-| Return a human-readable format of `pitchClass`. +-} +viewPitchClass : PitchClass -> String +viewPitchClass pitchClass = + case pitchClass of + C -> + "C" + + C_sharp -> + "C♯/D♭" + + D -> + "D" + + D_sharp -> + "D♯/E♭" + + E -> + "E" + + F -> + "F" + + F_sharp -> + "F♯/G♭" + + G -> + "G" + + G_sharp -> + "G♯/A♭" + + A -> + "A" + + A_sharp -> + "A♯/B♭" + + B -> + "B" + + +viewMode : Mode -> String +viewMode mode = + case mode of + MajorMode -> + "major" + + MinorMode -> + "minor" + + BluesMode -> + "blues" + + +{-| Return the human-readable format of `key`. +-} +viewKey : Key -> String +viewKey { pitchClass, mode } = + viewPitchClass pitchClass ++ " " ++ viewMode mode + + +{-| Returns a pairing of a scale-degree to the type of chord at that scale +degree. +-} +practiceChordsForMode : Mode -> Dict ScaleDegree ChordType +practiceChordsForMode mode = + case mode of + MajorMode -> + Dict.fromList + [ ( 1, Major ) + , ( 2, Minor ) + , ( 3, Minor ) + , ( 4, Major ) + , ( 5, Major ) + , ( 6, Minor ) + , ( 7, Diminished ) + ] + + MinorMode -> + Dict.fromList + [ ( 1, Minor ) + , ( 2, Diminished ) + , ( 3, Major ) + , ( 4, Minor ) + , ( 5, Minor ) + , ( 6, Major ) + , ( 7, Major ) + ] + + BluesMode -> + Dict.fromList + [ ( 1, MajorDominant7 ) + + -- While many refer to the blues progression as a I-IV-V, the IV + -- chord is really a MajorDominant7 made from the third scale + -- degree. + , ( 3, MajorDominant7 ) + , ( 5, MajorDominant7 ) + ] + + +{-| Returns a list of chords for a particular `key`. +-} +chordsForKey : Key -> List Chord +chordsForKey key = + let + chords = + practiceChordsForMode key.mode + in + notesForKey key + |> List.indexedMap + (\i note -> + case Dict.get (i + 1) chords of + Nothing -> + Nothing + + Just chordType -> + Just + (allInversions + |> List.Extra.andThen + (\inversion -> + [ { note = note + , chordType = chordType + , chordInversion = inversion + } + ] + ) + ) + ) + |> Maybe.Extra.values + |> List.concat diff --git a/users/wpcarro/website/sandbox/learnpianochords/src/UI.elm b/users/wpcarro/website/sandbox/learnpianochords/src/UI.elm new file mode 100644 index 0000000000..a6876c4f8a --- /dev/null +++ b/users/wpcarro/website/sandbox/learnpianochords/src/UI.elm @@ -0,0 +1,159 @@ +module UI exposing (..) + +import Html exposing (..) +import Html.Attributes exposing (..) +import Html.Events exposing (..) +import Responsive +import Tailwind + + +type Color + = Primary + | Secondary + + +bgForColor : Color -> String +bgForColor color = + case color of + Primary -> + "bg-gray-600" + + Secondary -> + "bg-gray-300" + + +textForColor : Color -> String +textForColor color = + case color of + Primary -> + "text-white" + + Secondary -> + "text-black" + + +simpleButton : + { label : String + , handleClick : msg + , color : Color + , classes : List String + } + -> Html msg +simpleButton { label, handleClick, color, classes } = + let + buttonClasses = + [ bgForColor color + , textForColor color + , "py-10" + , "lg:py-6" + , "px-20" + , "lg:px-12" + , "rounded-lg" + , Responsive.h2 + ] + in + button + [ class (Tailwind.use <| List.concat [ buttonClasses, classes ]) + , onClick handleClick + ] + [ text label ] + + +textToggleButton : + { label : String + , handleClick : msg + , classes : List String + , toggled : Bool + } + -> Html msg +textToggleButton { label, toggled, handleClick, classes } = + let + ( textColor, textTreatment ) = + if toggled then + ( "text-red-600", "underline" ) + + else + ( "text-black", "no-underline" ) + + buttonClasses = + [ textColor + , textTreatment + , "py-8" + , "lg:py-5" + , "px-10" + , "lg:px-6" + , Responsive.h2 + ] + in + button + [ class (Tailwind.use <| List.concat [ buttonClasses, classes ]) + , onClick handleClick + ] + [ text label ] + + +textField : + { placeholderText : String + , handleInput : String -> msg + , classes : List String + } + -> Html msg +textField { placeholderText, handleInput, classes } = + let + inputClasses = + [ "w-full" + , "py-10" + , "lg:py-6" + , "px-16" + , "lg:px-10" + , "border" + , "rounded-lg" + , Responsive.h2 + ] + in + input + [ class (Tailwind.use <| List.concat [ inputClasses, classes ]) + , onInput handleInput + , placeholder placeholderText + ] + [] + + +overlayButton : + { label : String + , handleClick : msg + , isVisible : Bool + } + -> Html msg +overlayButton { label, handleClick, isVisible } = + let + classes = + [ "fixed" + , "top-0" + , "left-0" + , "block" + , "z-40" + , "w-screen" + , "h-screen" + , Tailwind.if_ isVisible "opacity-100" "opacity-0" + ] + in + button + [ classes |> Tailwind.use |> class + , style "background-color" "rgba(0,0,0,1.0)" + , onClick handleClick + ] + [ h1 + [ style "-webkit-text-stroke-width" "2px" + , style "-webkit-text-stroke-color" "black" + , class <| + Tailwind.use + [ "transform" + , "-rotate-90" + , "text-white" + , "font-mono" + , Responsive.h1 + ] + ] + [ text label ] + ] diff --git a/users/wpcarro/website/sandbox/learnpianochords/src/server/.envrc b/users/wpcarro/website/sandbox/learnpianochords/src/server/.envrc new file mode 100644 index 0000000000..9e714732fe --- /dev/null +++ b/users/wpcarro/website/sandbox/learnpianochords/src/server/.envrc @@ -0,0 +1,7 @@ +source_up +use_nix +export SERVER_PORT=3000 +export CLIENT_PORT=8000 +# TODO(wpcarro): Prefer age-nix solution if possible. +export GOOGLE_CLIENT_ID="$(jq -j '.google | .clientId' < $WPCARRO/secrets.json)" +export STRIPE_API_KEY="$(jq -j '.stripe | .apiKey' < $WPCARRO/secrets.json)" diff --git a/users/wpcarro/website/sandbox/learnpianochords/src/server/.ghci b/users/wpcarro/website/sandbox/learnpianochords/src/server/.ghci new file mode 100644 index 0000000000..151d070ca1 --- /dev/null +++ b/users/wpcarro/website/sandbox/learnpianochords/src/server/.ghci @@ -0,0 +1,7 @@ +:set prompt "> " +:set -Wall + +:set -XOverloadedStrings +:set -XNoImplicitPrelude +:set -XRecordWildCards +:set -XTypeApplications diff --git a/users/wpcarro/website/sandbox/learnpianochords/src/server/API.hs b/users/wpcarro/website/sandbox/learnpianochords/src/server/API.hs new file mode 100644 index 0000000000..fe3671e7aa --- /dev/null +++ b/users/wpcarro/website/sandbox/learnpianochords/src/server/API.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +-------------------------------------------------------------------------------- +module API where +-------------------------------------------------------------------------------- +import Servant.API + +import qualified Types as T +-------------------------------------------------------------------------------- + +type API = "verify" + :> ReqBody '[JSON] T.VerifyGoogleSignInRequest + :> Post '[JSON] NoContent + :<|> "create-payment-intent" + :> ReqBody '[JSON] T.PaymentIntent + :> Post '[JSON] T.CreatePaymentIntentResponse diff --git a/users/wpcarro/website/sandbox/learnpianochords/src/server/App.hs b/users/wpcarro/website/sandbox/learnpianochords/src/server/App.hs new file mode 100644 index 0000000000..b7a31457b7 --- /dev/null +++ b/users/wpcarro/website/sandbox/learnpianochords/src/server/App.hs @@ -0,0 +1,57 @@ +-------------------------------------------------------------------------------- +module App where +-------------------------------------------------------------------------------- +import RIO hiding (Handler) +import Servant +import API +import Data.String.Conversions (cs) +import Control.Monad.IO.Class (liftIO) +import Network.Wai.Middleware.Cors +import GoogleSignIn (EncodedJWT(..), ValidationResult(..)) +import Utils + +import qualified Network.Wai.Handler.Warp as Warp +import qualified GoogleSignIn +import qualified Stripe +import qualified Types as T +-------------------------------------------------------------------------------- + +server :: T.Context -> Server API +server ctx@T.Context{..} = verifyGoogleSignIn + :<|> createPaymentIntent + where + verifyGoogleSignIn :: T.VerifyGoogleSignInRequest -> Handler NoContent + verifyGoogleSignIn T.VerifyGoogleSignInRequest{..} = do + validationResult <- liftIO $ GoogleSignIn.validateJWT False (EncodedJWT idToken) + case validationResult of + Valid _ -> do + -- If GoogleLinkedAccounts has email from JWT: + -- create a new session for email + -- Else: + -- Redirect the SPA to the sign-up / payment page + pure NoContent + err -> do + throwError err401 { errBody = err |> GoogleSignIn.explainResult |> cs } + + createPaymentIntent :: T.PaymentIntent -> Handler T.CreatePaymentIntentResponse + createPaymentIntent pmt = do + clientSecret <- liftIO $ Stripe.createPaymentIntent ctx pmt + pure T.CreatePaymentIntentResponse{..} + +run :: T.App +run = do + ctx@T.Context{..} <- ask + ctx + |> server + |> serve (Proxy @API) + |> cors (const $ Just corsPolicy) + |> Warp.run contextServerPort + |> liftIO + pure $ Right () + where + corsPolicy :: CorsResourcePolicy + corsPolicy = simpleCorsResourcePolicy + { corsOrigins = Just (["http://localhost:8000"], True) + , corsMethods = simpleMethods ++ ["PUT", "PATCH", "DELETE", "OPTIONS"] + , corsRequestHeaders = simpleHeaders ++ ["Content-Type", "Authorization"] + } diff --git a/users/wpcarro/website/sandbox/learnpianochords/src/server/Fixtures.hs b/users/wpcarro/website/sandbox/learnpianochords/src/server/Fixtures.hs new file mode 100644 index 0000000000..7c153e4228 --- /dev/null +++ b/users/wpcarro/website/sandbox/learnpianochords/src/server/Fixtures.hs @@ -0,0 +1,67 @@ +-------------------------------------------------------------------------------- +module Fixtures where +-------------------------------------------------------------------------------- +import RIO +import Web.JWT +import Utils + +import qualified Data.Map as Map +import qualified GoogleSignIn +import qualified TestUtils +import qualified Data.Time.Clock.POSIX as POSIX +import qualified System.IO.Unsafe as Unsafe +-------------------------------------------------------------------------------- + +-- | These are the JWT fields that I'd like to overwrite in the `googleJWT` +-- function. +data JWTFields = JWTFields + { overwriteSigner :: Signer + , overwriteAuds :: [StringOrURI] + , overwriteIss :: StringOrURI + , overwriteExp :: NumericDate + } + +defaultJWTFields :: JWTFields +defaultJWTFields = do + let tenDaysFromToday = POSIX.getPOSIXTime + |> Unsafe.unsafePerformIO + |> (\x -> x * 60 * 60 * 25 * 10) + |> numericDate + |> TestUtils.unsafeJust + JWTFields + { overwriteSigner = hmacSecret "secret" + , overwriteAuds = ["771151720060-buofllhed98fgt0j22locma05e7rpngl.apps.googleusercontent.com"] + |> fmap TestUtils.unsafeStringOrURI + , overwriteIss = TestUtils.unsafeStringOrURI "accounts.google.com" + , overwriteExp = tenDaysFromToday + } + +googleJWT :: JWTFields -> GoogleSignIn.EncodedJWT +googleJWT JWTFields{..} = + encodeSigned signer jwtHeader claimSet + |> GoogleSignIn.EncodedJWT + where + signer :: Signer + signer = overwriteSigner + + jwtHeader :: JOSEHeader + jwtHeader = JOSEHeader + { typ = Just "JWT" + , cty = Nothing + , alg = Just RS256 + , kid = Just "f05415b13acb9590f70df862765c655f5a7a019e" + } + + claimSet :: JWTClaimsSet + claimSet = JWTClaimsSet + { iss = Just overwriteIss + , sub = stringOrURI "114079822315085727057" + , aud = overwriteAuds |> Right |> Just + -- TODO: Replace date creation with a human-readable date constructor. + , Web.JWT.exp = Just overwriteExp + , nbf = Nothing + -- TODO: Replace date creation with a human-readable date constructor. + , iat = numericDate 1596752853 + , unregisteredClaims = ClaimsMap (Map.fromList []) + , jti = stringOrURI "0d3d7fa1fe05bedec0a91c88294936b2b4d1b13c" + } diff --git a/users/wpcarro/website/sandbox/learnpianochords/src/server/GoogleSignIn.hs b/users/wpcarro/website/sandbox/learnpianochords/src/server/GoogleSignIn.hs new file mode 100644 index 0000000000..dcccadcb70 --- /dev/null +++ b/users/wpcarro/website/sandbox/learnpianochords/src/server/GoogleSignIn.hs @@ -0,0 +1,111 @@ +-------------------------------------------------------------------------------- +module GoogleSignIn where +-------------------------------------------------------------------------------- +import RIO +import Data.String.Conversions (cs) +import Web.JWT +import Utils + +import qualified Network.HTTP.Simple as HTTP +import qualified Data.Text as Text +import qualified Web.JWT as JWT +import qualified Data.Time.Clock.POSIX as POSIX +-------------------------------------------------------------------------------- + +newtype EncodedJWT = EncodedJWT Text + deriving (Show) + +newtype DecodedJWT = DecodedJWT (JWT UnverifiedJWT) + deriving (Show) + +instance Eq DecodedJWT where + (DecodedJWT _) == (DecodedJWT _) = True + +data ValidationResult + = Valid DecodedJWT + | CannotDecodeJWT + | GoogleSaysInvalid Text + | NoMatchingClientIDs [StringOrURI] + | WrongIssuer StringOrURI + | StringOrURIParseFailure Text + | TimeConversionFailure + | MissingRequiredClaim Text + | StaleExpiry NumericDate + deriving (Eq, Show) + +-- | Returns True when the supplied `jwt` meets the following criteria: +-- * The token has been signed by Google +-- * The value of `aud` matches my Google client's ID +-- * The value of `iss` matches is "accounts.google.com" or +-- "https://accounts.google.com" +-- * The `exp` time has not passed +-- +-- Set `skipHTTP` to `True` to avoid making the network request for testing. +validateJWT :: Bool + -> EncodedJWT + -> IO ValidationResult +validateJWT skipHTTP (EncodedJWT encodedJWT) = do + case encodedJWT |> decode of + Nothing -> pure CannotDecodeJWT + Just jwt -> do + if skipHTTP then + continue jwt + else do + let request = "https://oauth2.googleapis.com/tokeninfo" + |> HTTP.setRequestQueryString [ ( "id_token", Just (cs encodedJWT) ) ] + res <- HTTP.httpLBS request + if HTTP.getResponseStatusCode res /= 200 then + pure $ GoogleSaysInvalid (res |> HTTP.getResponseBody |> cs) + else + continue jwt + where + continue :: JWT UnverifiedJWT -> IO ValidationResult + continue jwt = do + let audValues :: [StringOrURI] + audValues = jwt |> claims |> auds + expectedClientID :: Text + expectedClientID = "771151720060-buofllhed98fgt0j22locma05e7rpngl.apps.googleusercontent.com" + expectedIssuers :: [Text] + expectedIssuers = [ "accounts.google.com" + , "https://accounts.google.com" + ] + mExpectedClientID :: Maybe StringOrURI + mExpectedClientID = stringOrURI expectedClientID + mExpectedIssuers :: Maybe [StringOrURI] + mExpectedIssuers = expectedIssuers |> traverse stringOrURI + case (mExpectedClientID, mExpectedIssuers) of + (Nothing, _) -> pure $ StringOrURIParseFailure expectedClientID + (_, Nothing) -> pure $ StringOrURIParseFailure (Text.unwords expectedIssuers) + (Just clientID, Just parsedIssuers) -> + -- TODO: Prefer reading clientID from a config. I'm thinking of the + -- AppContext type having my Configuration + if not $ clientID `elem` audValues then + pure $ NoMatchingClientIDs audValues + else + case (jwt |> claims |> iss, jwt |> claims |> JWT.exp) of + (Nothing, _) -> pure $ MissingRequiredClaim "iss" + (_, Nothing) -> pure $ MissingRequiredClaim "exp" + (Just jwtIssuer, Just jwtExpiry) -> + if not $ jwtIssuer `elem` parsedIssuers then + pure $ WrongIssuer jwtIssuer + else do + mCurrentTime <- POSIX.getPOSIXTime |> fmap numericDate + case mCurrentTime of + Nothing -> pure TimeConversionFailure + Just currentTime -> + if not $ currentTime <= jwtExpiry then + pure $ StaleExpiry jwtExpiry + else + pure $ jwt |> DecodedJWT |> Valid + +-- | Attempt to explain the `ValidationResult` to a human. +explainResult :: ValidationResult -> String +explainResult (Valid _) = "Everything appears to be valid" +explainResult CannotDecodeJWT = "We had difficulty decoding the provided JWT" +explainResult (GoogleSaysInvalid x) = "After checking with Google, they claimed that the provided JWT was invalid: " ++ cs x +explainResult (NoMatchingClientIDs audFields) = "None of the values in the `aud` field on the provided JWT match our client ID: " ++ show audFields +explainResult (WrongIssuer issuer) = "The `iss` field in the provided JWT does not match what we expect: " ++ show issuer +explainResult (StringOrURIParseFailure x) = "We had difficulty parsing values as URIs" ++ show x +explainResult TimeConversionFailure = "We had difficulty converting the current time to a value we can use to compare with the JWT's `exp` field" +explainResult (MissingRequiredClaim claim) = "Your JWT is missing the following claim: " ++ cs claim +explainResult (StaleExpiry x) = "The `exp` field on your JWT has expired" ++ x |> show |> cs diff --git a/users/wpcarro/website/sandbox/learnpianochords/src/server/Main.hs b/users/wpcarro/website/sandbox/learnpianochords/src/server/Main.hs new file mode 100644 index 0000000000..228c3363bc --- /dev/null +++ b/users/wpcarro/website/sandbox/learnpianochords/src/server/Main.hs @@ -0,0 +1,37 @@ +-------------------------------------------------------------------------------- +module Main where +-------------------------------------------------------------------------------- +import RIO +import Prelude (putStr, putStrLn) + +import qualified Types as T +import qualified System.Envy as Envy +import qualified App +-------------------------------------------------------------------------------- + +-- | Attempt to read environment variables from the system and initialize the +-- Context data type for our application. +getAppContext :: IO (Either String T.Context) +getAppContext = do + mEnv <- Envy.decodeEnv + case mEnv of + Left err -> pure $ Left err + Right T.Env{..} -> pure $ Right T.Context + { contextGoogleClientID = envGoogleClientID + , contextStripeAPIKey = envStripeAPIKey + , contextServerPort = envServerPort + , contextClientPort = envClientPort + } + +main :: IO () +main = do + mContext <- getAppContext + case mContext of + Left err -> putStrLn err + Right ctx -> do + result <- runRIO ctx App.run + case result of + Left err -> do + putStr "Something went wrong when executing the application: " + putStrLn $ show err + Right _ -> putStrLn "The application successfully executed." diff --git a/users/wpcarro/website/sandbox/learnpianochords/src/server/Spec.hs b/users/wpcarro/website/sandbox/learnpianochords/src/server/Spec.hs new file mode 100644 index 0000000000..3c476bbf7b --- /dev/null +++ b/users/wpcarro/website/sandbox/learnpianochords/src/server/Spec.hs @@ -0,0 +1,74 @@ +-------------------------------------------------------------------------------- +module Spec where +-------------------------------------------------------------------------------- +import RIO +import Test.Hspec +import Utils +import Web.JWT (numericDate, decode) +import GoogleSignIn (EncodedJWT(..), DecodedJWT(..), ValidationResult(..)) + +import qualified GoogleSignIn +import qualified Fixtures as F +import qualified TestUtils +import qualified Data.Time.Clock.POSIX as POSIX +-------------------------------------------------------------------------------- + +main :: IO () +main = hspec $ do + describe "GoogleSignIn" $ + describe "validateJWT" $ do + let validateJWT' = GoogleSignIn.validateJWT True + it "returns a decode error when an incorrectly encoded JWT is used" $ do + validateJWT' (GoogleSignIn.EncodedJWT "rubbish") `shouldReturn` CannotDecodeJWT + + it "returns validation error when the aud field doesn't match my client ID" $ do + let auds = ["wrong-client-id"] + |> fmap TestUtils.unsafeStringOrURI + encodedJWT = F.defaultJWTFields { F.overwriteAuds = auds } + |> F.googleJWT + validateJWT' encodedJWT `shouldReturn` NoMatchingClientIDs auds + + it "returns validation success when one of the aud fields matches my client ID" $ do + let auds = ["wrong-client-id", "771151720060-buofllhed98fgt0j22locma05e7rpngl.apps.googleusercontent.com"] + |> fmap TestUtils.unsafeStringOrURI + encodedJWT@(EncodedJWT jwt) = + F.defaultJWTFields { F.overwriteAuds = auds } + |> F.googleJWT + decodedJWT = jwt |> decode |> TestUtils.unsafeJust |> DecodedJWT + validateJWT' encodedJWT `shouldReturn` Valid decodedJWT + + it "returns validation error when one of the iss field doesn't match accounts.google.com or https://accounts.google.com" $ do + let erroneousIssuer = TestUtils.unsafeStringOrURI "not-accounts.google.com" + encodedJWT = F.defaultJWTFields { F.overwriteIss = erroneousIssuer } + |> F.googleJWT + validateJWT' encodedJWT `shouldReturn` WrongIssuer erroneousIssuer + + it "returns validation success when the iss field matches accounts.google.com or https://accounts.google.com" $ do + let erroneousIssuer = TestUtils.unsafeStringOrURI "https://accounts.google.com" + encodedJWT@(EncodedJWT jwt) = + F.defaultJWTFields { F.overwriteIss = erroneousIssuer } + |> F.googleJWT + decodedJWT = jwt |> decode |> TestUtils.unsafeJust |> DecodedJWT + validateJWT' encodedJWT `shouldReturn` Valid decodedJWT + + it "fails validation when the exp field has expired" $ do + let mErroneousExp = numericDate 0 + case mErroneousExp of + Nothing -> True `shouldBe` False + Just erroneousExp -> do + let encodedJWT = F.defaultJWTFields { F.overwriteExp = erroneousExp } + |> F.googleJWT + validateJWT' encodedJWT `shouldReturn` StaleExpiry erroneousExp + + it "passes validation when the exp field is current" $ do + mFreshExp <- POSIX.getPOSIXTime + |> fmap (\x -> x * 60 * 60 * 24 * 10) -- 10 days later + |> fmap numericDate + case mFreshExp of + Nothing -> True `shouldBe` False + Just freshExp -> do + let encodedJWT@(EncodedJWT jwt) = + F.defaultJWTFields { F.overwriteExp = freshExp } + |> F.googleJWT + decodedJWT = jwt |> decode |> TestUtils.unsafeJust |> DecodedJWT + validateJWT' encodedJWT `shouldReturn` Valid decodedJWT diff --git a/users/wpcarro/website/sandbox/learnpianochords/src/server/Stripe.hs b/users/wpcarro/website/sandbox/learnpianochords/src/server/Stripe.hs new file mode 100644 index 0000000000..5370b90abe --- /dev/null +++ b/users/wpcarro/website/sandbox/learnpianochords/src/server/Stripe.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +-------------------------------------------------------------------------------- +module Stripe where +-------------------------------------------------------------------------------- +import RIO +import Prelude (print) +import Data.String.Conversions (cs) +import Data.Aeson +import Network.HTTP.Req + +import qualified Types as T +-------------------------------------------------------------------------------- + +endpoint :: Text -> Url 'Https +endpoint slug = + https "api.stripe.com" /: "v1" /: slug + +post :: (FromJSON b) => Text -> Text -> T.PaymentIntent -> IO (JsonResponse b) +post apiKey slug T.PaymentIntent{..} = runReq defaultHttpConfig $ do + let params = "amount" =: paymentIntentAmount + <> "currency" =: paymentIntentCurrency + req POST (endpoint slug) (ReqBodyUrlEnc params) jsonResponse (oAuth2Bearer (cs apiKey)) + +createPaymentIntent :: T.Context -> T.PaymentIntent -> IO T.Secret +createPaymentIntent T.Context{..} pmtIntent = do + res <- post contextStripeAPIKey "payment_intents" pmtIntent + let T.StripePaymentIntent{..} = responseBody res :: T.StripePaymentIntent + pure pmtIntentClientSecret diff --git a/users/wpcarro/website/sandbox/learnpianochords/src/server/TestUtils.hs b/users/wpcarro/website/sandbox/learnpianochords/src/server/TestUtils.hs new file mode 100644 index 0000000000..24054bf47a --- /dev/null +++ b/users/wpcarro/website/sandbox/learnpianochords/src/server/TestUtils.hs @@ -0,0 +1,17 @@ +-------------------------------------------------------------------------------- +module TestUtils where +-------------------------------------------------------------------------------- +import RIO +import Web.JWT +import Data.String.Conversions (cs) +-------------------------------------------------------------------------------- + +unsafeStringOrURI :: String -> StringOrURI +unsafeStringOrURI x = + case stringOrURI (cs x) of + Nothing -> error $ "Failed to convert to StringOrURI: " ++ x + Just res -> res + +unsafeJust :: Maybe a -> a +unsafeJust Nothing = error "Attempted to force a Nothing to be a something" +unsafeJust (Just x) = x diff --git a/users/wpcarro/website/sandbox/learnpianochords/src/server/Types.hs b/users/wpcarro/website/sandbox/learnpianochords/src/server/Types.hs new file mode 100644 index 0000000000..4a72865153 --- /dev/null +++ b/users/wpcarro/website/sandbox/learnpianochords/src/server/Types.hs @@ -0,0 +1,146 @@ +--------------------------------------------------------------------------------G +module Types where +-------------------------------------------------------------------------------- +import RIO +import Data.Aeson +import Network.HTTP.Req +import Web.Internal.HttpApiData (ToHttpApiData(..)) +import System.Envy (FromEnv, fromEnv, env) +-------------------------------------------------------------------------------- + +-- | Read from .envrc +data Env = Env + { envGoogleClientID :: !Text + , envServerPort :: !Int + , envClientPort :: !Int + , envStripeAPIKey :: !Text + } deriving (Eq, Show) + +instance FromEnv Env where + fromEnv _ = do + envGoogleClientID <- env "GOOGLE_CLIENT_ID" + envStripeAPIKey <- env "STRIPE_API_KEY" + envServerPort <- env "SERVER_PORT" + envClientPort <- env "CLIENT_PORT" + pure Env {..} + +-- | Application context: a combination of Env and additional values. +data Context = Context + { contextGoogleClientID :: !Text + , contextStripeAPIKey :: !Text + , contextServerPort :: !Int + , contextClientPort :: !Int + } + +-- | Top-level except for our application, as RIO recommends defining. +type Failure = () + +-- | When our app executes along the "happy path" this is the type of result it +-- produces. +type Success = () + +-- | This is our application monad. +type AppM = RIO Context + +-- | The concrete type of our application. +type App = AppM (Either Failure Success) + +data VerifyGoogleSignInRequest = VerifyGoogleSignInRequest + { idToken :: !Text + } deriving (Eq, Show) + +instance FromJSON VerifyGoogleSignInRequest where + parseJSON = withObject "VerifyGoogleSignInRequest" $ \x -> do + idToken <- x .: "idToken" + pure VerifyGoogleSignInRequest{..} + +data GoogleLinkedAccount = GoogleLinkedAccount + { + -- { googleLinkedAccountUUID :: UUID + -- , googleLinkedAccountEmail :: Email + -- , googleLinkedAccountTsCreated :: Timestamp + googleLinkedAccountGivenName :: !(Maybe Text) + , googleLinkedAccountFamilyName :: !(Maybe Text) + , googleLinkedAccountFullName :: !(Maybe Text) + -- , googleLinkedAccountPictureURL :: URL + -- , googleLinkedAccountLocale :: Maybe Locale + } deriving (Eq, Show) + +data PayingCustomer = PayingCustomer + { + -- { payingCustomerAccountUUID :: UUID + -- , payingCustomerTsCreated :: Timestamp + } deriving (Eq, Show) + +data Session = Session + { + -- { sessionUUID :: UUID + -- , sessionAccountUUID :: UUID + -- , sessionTsCreated :: Timestamp + } deriving (Eq, Show) + +data CurrencyCode = USD + deriving (Eq, Show) + +instance ToJSON CurrencyCode where + toJSON USD = String "usd" + +instance FromJSON CurrencyCode where + parseJSON = withText "CurrencyCode" $ \x -> + case x of + "usd" -> pure USD + _ -> fail "Expected a valid currency code like: \"usd\"" + +instance ToHttpApiData CurrencyCode where + toQueryParam USD = "usd" + +data PaymentIntent = PaymentIntent + { paymentIntentAmount :: !Int + , paymentIntentCurrency :: !CurrencyCode + } deriving (Eq, Show) + +instance ToJSON PaymentIntent where + toJSON PaymentIntent{..} = + object [ "amount" .= paymentIntentAmount + , "currency" .= paymentIntentCurrency + ] + +instance FromJSON PaymentIntent where + parseJSON = withObject "" $ \x -> do + paymentIntentAmount <- x .: "amount" + paymentIntentCurrency <- x .: "currency" + pure PaymentIntent{..} + +instance QueryParam PaymentIntent where + queryParam = undefined + +-- All applications have their secrets... Using the secret type ensures that no +-- sensitive information will get printed to the screen. +newtype Secret = Secret Text deriving (Eq) + +instance Show Secret where + show (Secret _) = "[REDACTED]" + +instance ToJSON Secret where + toJSON (Secret x) = toJSON x + +instance FromJSON Secret where + parseJSON = withText "Secret" $ \x -> pure $ Secret x + +data CreatePaymentIntentResponse = CreatePaymentIntentResponse + { clientSecret :: Secret + } deriving (Eq, Show) + +instance ToJSON CreatePaymentIntentResponse where + toJSON CreatePaymentIntentResponse{..} = + object [ "clientSecret" .= clientSecret + ] + +data StripePaymentIntent = StripePaymentIntent + { pmtIntentClientSecret :: Secret + } deriving (Eq, Show) + +instance FromJSON StripePaymentIntent where + parseJSON = withObject "StripeCreatePaymentIntentResponse" $ \x -> do + pmtIntentClientSecret <- x .: "client_secret" + pure StripePaymentIntent{..} diff --git a/users/wpcarro/website/sandbox/learnpianochords/src/server/Utils.hs b/users/wpcarro/website/sandbox/learnpianochords/src/server/Utils.hs new file mode 100644 index 0000000000..2f401af2fb --- /dev/null +++ b/users/wpcarro/website/sandbox/learnpianochords/src/server/Utils.hs @@ -0,0 +1,8 @@ +-------------------------------------------------------------------------------- +module Utils where +-------------------------------------------------------------------------------- +import Data.Function ((&)) +-------------------------------------------------------------------------------- + +(|>) :: a -> (a -> b) -> b +(|>) = (&) diff --git a/users/wpcarro/website/sandbox/learnpianochords/src/server/default.nix b/users/wpcarro/website/sandbox/learnpianochords/src/server/default.nix new file mode 100644 index 0000000000..262693ae82 --- /dev/null +++ b/users/wpcarro/website/sandbox/learnpianochords/src/server/default.nix @@ -0,0 +1,28 @@ +{ depot, ... }: + +depot.users.wpcarro.buildHaskell.program { + name = "server"; + srcs = builtins.path { + path = ./.; + name = "LearnPianoChords-server-src"; + }; + ghcExtensions = [ + "OverloadedStrings" + "NoImplicitPrelude" + "RecordWildCards" + "TypeApplications" + ]; + deps = hpkgs: with hpkgs; [ + servant-server + aeson + wai-cors + warp + jwt + unordered-containers + base64 + http-conduit + rio + envy + req + ]; +} diff --git a/users/wpcarro/website/sandbox/learnpianochords/src/server/index.html b/users/wpcarro/website/sandbox/learnpianochords/src/server/index.html new file mode 100644 index 0000000000..459a5c8c82 --- /dev/null +++ b/users/wpcarro/website/sandbox/learnpianochords/src/server/index.html @@ -0,0 +1,35 @@ +<!DOCTYPE html> +<html lang="en"> + <head> + <meta charset="UTF-8" /> + <title>Google Sign-in</title> + <script src="https://apis.google.com/js/platform.js" async defer></script> + <meta name="google-signin-client_id" content="771151720060-buofllhed98fgt0j22locma05e7rpngl.apps.googleusercontent.com"> + </head> + <body> + <div class="g-signin2" data-onsuccess="onSignIn"></div> + <a href="#" onclick="signOut();">Sign out</a> + <script> + function onSignIn(googleUser) { + var idToken = googleUser.getAuthResponse().id_token; + fetch('http://localhost:3000/verify', { + method: 'POST', + headers: { + 'Content-Type': 'application/json', + }, + body: JSON.stringify({ + idToken: idToken, + }) + }) + .then(x => console.log(x)) + .catch(err => console.error(err)); + } + function signOut() { + var auth2 = gapi.auth2.getAuthInstance(); + auth2.signOut().then(function () { + console.log('User signed out.'); + }); + } + </script> + </body> +</html> diff --git a/users/wpcarro/website/sandbox/learnpianochords/src/server/init.sql b/users/wpcarro/website/sandbox/learnpianochords/src/server/init.sql new file mode 100644 index 0000000000..c220bd4406 --- /dev/null +++ b/users/wpcarro/website/sandbox/learnpianochords/src/server/init.sql @@ -0,0 +1,41 @@ +BEGIN TRANSACTION; + +DROP TABLE IF EXISTS GoogleLinkedAccounts; +DROP TABLE IF EXISTS PayingCustomers; +DROP TABLE IF EXISTS Sessions; + +-- Store some of the information that Google provides to us from the JWT. +CREATE TABLE GoogleLinkedAccounts ( + accountUUID TEXT CHECK(LENGTH(uuid) == 36) NOT NULL UNIQUE, + email TEXT NOT NULL UNIQUE, + tsCreated TEXT NOT NULL, -- 'YYYY-MM-DD HH:MM:SS' + givenName TEXT, + familyName TEXT, + fullName TEXT, + pictureURL TEXT, + locale TEXT, + PRIMARY KEY (accountUUID) +); + +-- Track which of our customers have a paid account. +-- Defines a one-to-one relationship between: +-- GoogleLinkedAccounts and PayingCustomers +CREATE TABLE PayingCustomers ( + accountUUID TEXT, + tsCreated TEXT, + PRIMARY KEY (accountUUID), + FOREIGN KEY (accountUUID) REFERENCES GoogleLinkedAccounts ON DELETE CASCADE +); + +-- Define mobile and web sessions for our users. +-- Defines a one-to-many relationship between: +-- GoogleLinkedAccounts and Sessions +CREATE TABLE Sessions ( + sessionUUID TEXT CHECK(LENGTH(sessionUUID) == 36) NOT NULL UNIQUE, + accountUUID TEXT, + tsCreated TEXT NOT NULL, -- 'YYYY-MM-DD HH:MM:SS' + PRIMARY KEY (sessionUUID) + FOREIGN KEY(accountUUID) REFERENCES GoogleLinkedAccounts ON DELETE CASCADE +); + +COMMIT; diff --git a/users/wpcarro/website/sandbox/learnpianochords/src/server/shell.nix b/users/wpcarro/website/sandbox/learnpianochords/src/server/shell.nix new file mode 100644 index 0000000000..6ec8264470 --- /dev/null +++ b/users/wpcarro/website/sandbox/learnpianochords/src/server/shell.nix @@ -0,0 +1,18 @@ +{ depot, ... }: + +depot.users.wpcarro.buildHaskell.shell { + deps = hpkgs: with hpkgs; [ + hspec + servant-server + aeson + wai-cors + warp + jwt + unordered-containers + base64 + http-conduit + rio + envy + req + ]; +} |